-
Notifications
You must be signed in to change notification settings - Fork 5
/
ScottyHttpServer.hs
180 lines (152 loc) · 8.1 KB
/
ScottyHttpServer.hs
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
{-# LANGUAGE OverloadedStrings #-} -- Mandatory language overload to overload String
{-# LANGUAGE DeriveGeneric #-}
{-| This http server has been build in top of open source library http://hackage.haskell.org/package/scotty-}
module ScottyHttpServer where
import Web.Scotty
import Data.Monoid ((<>))
import Data.Aeson (FromJSON, ToJSON, encode,decode)
import GHC.Generics
import ModelTypes
import MySQLConnector
import ConnectorManager
import Data.ByteString.Lazy.Char8 (ByteString)
import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File)
import Data.Text.Lazy (Text)
import Control.Concurrent (myThreadId,newEmptyMVar,forkIO,threadDelay,putMVar,takeMVar)
import System.Random (randomRIO)
import Control.Concurrent.Async (async,wait)
import CircuitBreaker
import Data.IORef (newIORef,IORef,atomicModifyIORef,readIORef,writeIORef)
import Control.Monad.IO.Class (liftIO)
import Text.Read (lift)
import Network.HTTP.Types.Status
--import Data.ByteString (unpack)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.ByteString.Lazy.Char8 (ByteString)
port = 3000 :: Int
{-| Thanks to type class we define that any [User, Profile and Address] are JSON serializable/deserializable.|-}
instance ToJSON User
instance FromJSON User
instance ToJSON Profile
instance FromJSON Profile
instance ToJSON Address
instance FromJSON Address
{-| Using [scotty] passing [port] and [routes] we define the http server-}
scottyServer :: IO ()
scottyServer = do
print ("Starting Server at port " ++ show port)
state <- newIORef $ Close [] 0 -- We create a state to keep the state of Server
scotty port (routes state)
{-| We define the routes thanks to REST operators [get, post, put, delete, patch] which expect to
receive a [RoutePattern] as a path and a [ActionM] as the action of the request. Then we return a [ScottyM]-}
routes :: IORef CircuitBreakerState -> ScottyM()
routes state = do get "/service" responseService
get "/author" responseName
get "/users" (responseUsers state)
get "/user/id/:id" responseUserById
get "/user/name/:name" responseUserByName
post "/user/" responseCreateUser
put "/user/" updateUser
delete "/users/:id" responseDeleteById
get "/address/id/:id" responseAddressById
post "/profile/" createProfile
get "/profile/id/:id" responseProfileById
get "/error" errorResponse
get "/errorJson" errorJsonResponse
{-| We use [text] operator from scotty we render the response in text/plain-}
responseService :: ActionM ()
responseService = text "First Haskell service 1.0"
responseName :: ActionM ()
responseName = text "Paul Perez Garcia"
-- | Profile
-- ---------
{-| -[Aeson] library and encode operator, we can use [json] operator to allow us to encode object into json.
- [liftAndCatchIO] operator is used to extract from the IO monad the type and add it to ActionM monad.
- [forkIO] operator allow use run a do block in a green thread allowing tun multiple process in parallel like here.
|-}
createProfile :: ActionM ()
createProfile = do
maybeProfile <- getProfileParam
user <- return (getUserFromMaybeProfile maybeProfile)
address <- return (getAddressFromMaybeProfile maybeProfile)
emptyUserVar <- liftAndCatchIO $ newEmptyMVar
liftAndCatchIO $ forkIO $ do
status <- insertUser user
putMVar emptyUserVar status
emptyAddressVar <- liftAndCatchIO $ newEmptyMVar
liftAndCatchIO $ forkIO $ do
status <- insertAddress address
putMVar emptyAddressVar status
userStatus <- liftAndCatchIO $ takeMVar emptyUserVar
addressStatus <- liftAndCatchIO $ takeMVar emptyAddressVar
json (show userStatus)
{-| Here we go to the MySQL connector to search with the same id for User and Address tables. Because both are
separate tables and that process can be done in parallel we run every search in a green thread, this time
to improve our knowledge in the concurrency we use [Async] operator, which just like forkIO run the process
into another thread, and return a Monad Async that contains the value of the response process.
Then using [wait] operator we wait until that green threads finish his job.-}
responseProfileById :: ActionM ()
responseProfileById = do id <- param "id"
userAsync <- liftAndCatchIO $ async $ getUserById id
addressAsync <- liftAndCatchIO $ async $ getAddressById id
either <- liftAndCatchIO $ wait userAsync
address <- liftAndCatchIO $ wait addressAsync
profile <- liftAndCatchIO $ return $ Profile (getUserFromEither either) address
json profile
-- | User
-- ---------
responseUsers :: IORef CircuitBreakerState -> ActionM ()
responseUsers state = do either <- liftAndCatchIO $ selectAllUsers state
json (show either)
responseUserByName :: ActionM ()
responseUserByName = do name <- param "name"
either <- liftAndCatchIO $ getUserByUserName name
json (show either)
{-| In scotty we have [param] operator which used passing the uri param name we can extract the value. -}
responseUserById :: ActionM ()
responseUserById = do id <- extractUriParam "id"
either <- liftAndCatchIO $ selectUserById id
json (show either)
extractUriParam :: Text -> ActionM Int
extractUriParam param = Web.Scotty.param param
{-| This part of the program is really interested, we are using function where first we need to call insertUser
passing a [User] but we have a [Maybe User] so we use a functor [<*>] to extract the User from the Maybe.
Then we have [sequence] operator which does:
-- | Evaluate each monadic action in the structure from left to right, and collect the results.
Then finally we need to lift the response from insertUser [IO OK] to [OK] and to do that we use
the operator [liftAndCatchIO] which does:
-- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.-}
responseCreateUser :: ActionM ()
responseCreateUser = do maybeUser <- getUserParam
status <- liftAndCatchIO $ sequence $ createUser <$> maybeUser
json (show status)
updateUser :: ActionM ()
updateUser = do maybeUser <- getUserParam
status <- liftAndCatchIO $ sequence $ updateUserById <$> maybeUser
json (show status)
responseDeleteById :: ActionM ()
responseDeleteById = do id <- param "id"
status <- liftAndCatchIO $ deleteUserById id
json (show status)
errorResponse :: ActionM ()
errorResponse = do liftIO $ print ("Request received")
users <- liftAndCatchIO $ return $ [(User 1 "Paul")]
Web.Scotty.status status500 >> text "Error" --json (show users)
errorJsonResponse :: ActionM ()
errorJsonResponse = do liftIO $ print ("Request received")
users <- liftAndCatchIO $ return $ [(User 1 "Paul")]
Web.Scotty.status status401 >> json (show users)
-- | Address
-- ---------
responseAddressById :: ActionM ()
responseAddressById = do id <- param "id"
address <- liftAndCatchIO $ getAddressById id
json address
{-| In scotty we have [body] operator to get the request body.
We also use [decode] operator to extract and transform from json to Maybe of type we specify in the type signature-}
getUserParam :: ActionT Text IO (Maybe User)
getUserParam = do requestBody <- body
return (decode requestBody)
getProfileParam :: ActionT Text IO (Maybe Profile)
getProfileParam = do requestBody <- body
return (decode requestBody)