1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
#!/usr/bin/env stack
{- stack
--nix
--resolver lts-10.3
--install-ghc
runghc
--package http-types
--package yesod
--package yesod-core
--package text
--package aeson
--package acid-state
--package cassava
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Acid
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Csv as Csv
import Data.SafeCopy
import Data.Semigroup
import qualified Data.Vector as Vector
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 hiding (take)
import Yesod hiding (Update, update, get)
import Network.HTTP.Types.Status (status400, status200)
import Data.Aeson
--------------------------------------------------------------------
-- | Here be the state and data model stuff.
-- | A type to describe the shape of our core model
data Caller = Caller
{ name :: Text
, number :: Text
, context :: Text
}
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)
-- | Cons the caller to database.
addCaller :: Caller -> Update Database ()
addCaller caller = do
Database callers <- get
put $ Database (caller:callers)
-- | Grab a subset of the caller list.
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
{ appState :: AcidState Database
}
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
data ApiError = ApiError
{ msg :: Text
}
deriving (Show, Eq, Generic, ToJSON, FromJSON)
-- FIXME
findByNumber = id
getQueryR :: Handler RepJson
getQueryR = do
qm <- lookupGetParam "number"
case qm of
Nothing -> do
app <- getYesod
let db = appState app
callers <- liftIO $ query db (ViewCallers 20)
sendStatusJSON status400 $ callers
Just q -> do
app <- getYesod
let db = appState app
sendStatusJSON status200 $ object [ "msg" .= ("FIXME" :: Text) ]
postNumberR :: Handler RepJson
postNumberR = do
(obj :: Result Caller) <- parseJsonBody
case obj of
Error err ->
sendStatusJSON status400 $ ApiError $ "Invalid request. Could not parse JSON body: " <> pack err
Success caller -> do
app <- getYesod
let db = appState app
liftIO $ update db $ AddCaller caller
sendStatusJSON status200 $ caller
-- | Start a simple warp server on 3000
main :: IO ()
main = do
seedData <- BSL.readFile "seed.csv"
database <- openLocalStateFrom "database/" (Database [])
case Csv.decode Csv.NoHeader seedData of
Left err ->
fail err
Right v ->
Vector.forM_ v $ \(number, context, name) -> do
update database $ AddCaller $ Caller name number context
putStrLn $ unpack $ name <> number <> context
warp 3000 (App database)
|
