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
|
#!/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
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# 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 hiding (take)
import Yesod hiding (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
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 ->
sendStatusJSON status400 $ (ApiError "Invalid request. Could not parse 'number' parameter.")
Just q ->
sendStatusJSON status200 $ object [ "msg" .= ("FIXME" :: Text) ]
postNumberR :: Handler RepJson
postNumberR = do
(obj :: Result Value) <- parseJsonBody
case obj of
Error err ->
sendStatusJSON status400 $ ApiError $ "Invalid request. Could not parse JSON body: " <> pack err
Success v ->
sendStatusJSON status200 $ object [ "msg" .= ("FIXME" :: Text) ]
-- | Start a simple warp server on 3000
main :: IO ()
main = warp 3000 App
|
