summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2018-01-22 22:40:47 -0800
committerBen Sima <ben@bsima.me>2018-01-22 22:40:47 -0800
commitbb45fa6322fc7d2933016ae5e8a8b0d4ed8faad0 (patch)
tree956037c6d94deddd2ae24601cb525e3cdd747a51
parentf221c38f2c6c5f99d2e88821cba63cebc7a04221 (diff)
Initiate acid state
Unfortunately the acid-state package isn't on Stackage, so I need to pull it elsewhere. `stack script` doesn't support this, but `stack runghc` does. It's a bit slower and less reliable, but that's okay for now. https://github.com/commercialhaskell/stack/issues/3370#issuecomment-324124780 https://docs.haskellstack.org/en/stable/GUIDE/#writing-independent-and-reliable-scripts
-rwxr-xr-xmain.hs68
1 files changed, 51 insertions, 17 deletions
diff --git a/main.hs b/main.hs
index 966ea96..14b896d 100755
--- a/main.hs
+++ b/main.hs
@@ -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