BasicElmishWebserver.hs

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}


module Main (main) where

import Control.Applicative
import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.Reader as CMR
import Data.Default.Class
import Data.String
import Data.Text.Lazy (Text)
import Network.Wai.Middleware.RequestLogger
import Web.Scotty.Trans (ScottyT)
import qualified Web.Scotty.Trans as Web
import Flow


-- MAIN -- 


main :: IO ()
main = do
    STM.newTVarIO initialModel
        >>= initScotty


initScotty :: STM.TVar Model -> IO ()
initScotty modelMemory =
    Web.scottyT 3000 (runActionToIO modelMemory) router


runActionToIO :: STM.TVar Model -> App a -> IO a
runActionToIO modelMemory app = 
    CMR.runReaderT (run app) modelMemory


-- TYPES --


newtype Model 
    = Model 
        { count :: Int }


initialModel :: Model
initialModel =
    Model 0


newtype App a
    = App 
        { run :: CMR.ReaderT (STM.TVar Model) IO a }
            deriving 
                ( Applicative
                , Functor
                , Monad
                , CMR.MonadIO
                , CMR.MonadReader (STM.TVar Model)
                )


setApp :: CMR.MonadTrans t => App a -> t App a
setApp = 
    CMR.lift


getFromApp :: (Model -> b) -> App b
getFromApp f = 
    CMR.ask 
        >>= CMR.liftIO . STM.readTVarIO 
        >>= return . f


mapModel :: (Model -> Model) -> App ()
mapModel f = 
    CMR.ask 
        >>= CMR.liftIO . STM.atomically . flip STM.modifyTVar' f


-- ROUTER --


router :: ScottyT Text App ()
router =
    Web.middleware logStdoutDev 
    >> Web.get "/" sendCount
    >> (Web.get "/plusone" $ do
            setApp (mapModel addOne)
            Web.redirect "/")

    >> (Web.get "/plustwo" $ do
            setApp (mapModel addTwo)
            Web.redirect "/")
        

addTwo :: Model -> Model
addTwo model =
    Model { count = count model + 2 }


addOne :: Model -> Model
addOne model =
    Model { count = count model + 1 }


sendCount :: Web.ActionT Text App ()
sendCount =
    setApp (getFromApp count) 
        >>= countToAction


countToAction :: Int -> Web.ActionT Text App ()
countToAction c =
    c
        |> show
        |> fromString
        |> Web.text