From bb45fa6322fc7d2933016ae5e8a8b0d4ed8faad0 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 22 Jan 2018 22:40:47 -0800
Subject: 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
---
 main.hs | 68 ++++++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 51 insertions(+), 17 deletions(-)

(limited to 'main.hs')

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
-- 
cgit v1.2.3