Can't map Message

Anonymous Coward 2018-04-13 20:22:57.489791 UTC

1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE DeriveGeneric #-}
5import Control.Concurrent
6import Control.Exception (bracket)
7import Control.Monad.IO.Class
8import Database.SQLite.Simple
9import Network.HTTP.Client (newManager, defaultManagerSettings)
10import Network.Wai.Handler.Warp
11import GHC.Generics
12import Servant
13import Servant.Client
14
15
16data Message = Message
17 { name :: String
18 , text :: String
19 } deriving (Show, Generic)
20
21instance FromRow Message where
22 fromRow = Message <$> field <*> field
23
24type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
25 :<|> Get '[JSON] [Message]
26
27api :: Proxy API
28api = Proxy
29
30initDB :: FilePath -> IO ()
31initDB dbfile = withConnection dbfile $ \conn ->
32 execute_ conn
33 "CREATE TABLE IF NOT EXISTS messages ( \
34 \name text not null, \
35 \text text not null \
36 \)"
37
38
39server :: FilePath -> Server API
40server dbfile = postMessage :<|> getMessages
41
42 where postMessage :: Message -> Handler NoContent
43 postMessage msg = do
44 liftIO . withConnection dbfile $ \conn ->
45 execute conn
46 "INSERT INTO messages (name, text) VALUES (?, ?)"
47 ((name msg), (text msg))
48 return NoContent
49
50 getMessages :: Handler [Message]
51 getMessages = fmap (map fromRow) . liftIO $
52 withConnection dbfile $ \conn ->
53 query_ conn "SELECT name, text FROM messages"
54
55runApp :: FilePath -> IO ()
56runApp dbfile = run 8080 (serve api $ server dbfile)
57
58
59
60postMsg :: Message -> ClientM NoContent
61getMsgs :: ClientM [Message]
62postMsg :<|> getMsgs = client api
63
64main :: IO ()
65main = do
66 -- you could read this from some configuration file,
67 -- environment variable or somewhere else instead.
68 let dbfile = "test.db"
69 initDB dbfile
70 mgr <- newManager defaultManagerSettings
71 bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
72 ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
73 postMsg (Message "hello" "world")
74 getMsgs
75 print ms