diff options
| -rwxr-xr-x | main.hs | 68 |
1 files changed, 51 insertions, 17 deletions
@@ -3,14 +3,16 @@ --nix --resolver lts-10.3 --install-ghc - script + runghc --package http-types --package yesod --package yesod-core --package text --package aeson + --package acid-state -} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,29 +21,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} +import Data.Acid +import Data.SafeCopy import Data.Semigroup +import Data.Data (Data, Typeable) import GHC.Generics import Control.Monad +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) import Data.Maybe (isJust) -import Data.Text -import Yesod +import Data.Text hiding (take) +import Yesod hiding (Update, get) import Network.HTTP.Types.Status (status400, status200) import Data.Aeson -data App = App +-------------------------------------------------------------------- +-- | Here be the state and data model stuff. -mkYesod "App" [parseRoutes| -/query QueryR GET -/number NumberR POST -|] - --- | Start a simple warp server on 3000 -main :: IO () -main = warp 3000 App - --- | Initiate Yesod. The default method instances are fine for a prototype or --- demo app. -instance Yesod App -- | A type to describe the shape of our core model data Caller = Caller @@ -51,8 +47,42 @@ data Caller = Caller } deriving (Show, Eq, Generic, ToJSON, FromJSON) +$(deriveSafeCopy 0 'base ''Caller) + +-- | The database is just a list of @Caller@ records. +data Database = Database [Caller] + +$(deriveSafeCopy 0 'base ''Database) + +-- | Append the caller the database. +addCaller :: Caller -> Update Database () +addCaller caller = do + Database callers <- get + put $ Database (caller:callers) + +-- | Grab a subset of the callers +viewCallers :: Int -> Query Database [Caller] +viewCallers limit = do + Database callers <- ask + return $ take limit callers + +-- | This generates @AddCaller@ and @ViewCallers@ types automatically. +$(makeAcidic ''Database ['addCaller, 'viewCallers]) + +----------------------------------------------------------------------- +-- | Here be the HTTP stuff + +data App = App + +mkYesod "App" [parseRoutes| +/query QueryR GET +/number NumberR POST +|] + +-- | Initiate Yesod. The default method instances are fine for a prototype or +-- demo app. +instance Yesod App --- | Standardize errors. data ApiError = ApiError { msg :: Text } @@ -81,3 +111,7 @@ postNumberR = do Success v -> sendStatusJSON status200 $ object [ "msg" .= ("FIXME" :: Text) ] + +-- | Start a simple warp server on 3000 +main :: IO () +main = warp 3000 App |