@@ -0,0 +1,115 @@
1+module Types.Server
2+ ( module Network.HTTP.Types.Status,
3+ module Network.HTTP.Types.Header,
4+ ServerResponse (..),
5+ defaultServerResponse,
6+ addCookies,
7+ ServerEnv (..),
8+ ToResponseBody (..),
9+ FromResponseBody (..),
10+ NoBody (..),
11+ JsonBody (..),
12+ ServerError (..),
13+ throwServerError,
14+ ResponseError,
15+ MonadError,
16+ )
17+where
18+
19+import Control.Concurrent.STM.TVar
20+import Control.Monad.Except
21+import qualified Data.Aeson as A
22+import Data.Bifunctor
23+import qualified Data.ByteString.Builder as BS
24+import qualified Data.ByteString.Lazy as BSL
25+import Data.ByteString.Lazy (ByteString)
26+import qualified Data.ByteString.Lazy.Char8 as BSLC
27+import Data.Map (Map)
28+import Data.Text (Text)
29+import qualified Data.Text.Encoding as T
30+import Network.HTTP.Types.Header
31+import Network.HTTP.Types.Status
32+import Types.Post
33+import Types.Users
34+import Web.Cookie
35+
36+data ServerEnv
37+ = ServerEnv
38+ { users :: TVar (Map Username User),
39+ cookies :: TVar (Map (Hash RandomCookie) Username),
40+ posts :: TVar [Post]
41+ }
42+
43+data ServerResponse a
44+ = ServerResponse
45+ { responseBody :: Maybe a,
46+ responseStatus :: Status,
47+ responseHeaders :: ResponseHeaders
48+ }
49+
50+defaultServerResponse :: ServerResponse a
51+defaultServerResponse =
52+ ServerResponse
53+ { responseBody = Nothing,
54+ responseStatus = status200,
55+ responseHeaders = []
56+ }
57+
58+addCookies :: SetCookie -> ServerResponse a -> ServerResponse a
59+addCookies c r =
60+ r
61+ { responseHeaders = ("Set-Cookie", newCookies) : responseHeaders r
62+ }
63+ where
64+ newCookies = BSL.toStrict . BS.toLazyByteString $ renderSetCookie c
65+
66+class ToResponseBody r where
67+ toBody :: r -> ByteString
68+
69+class FromResponseBody r where
70+ fromBody :: ByteString -> Either String r
71+
72+data NoBody = NoBody
73+
74+instance ToResponseBody NoBody where
75+ toBody _ = ""
76+
77+instance FromResponseBody NoBody where
78+ fromBody _ = return NoBody
79+
80+data JsonBody a = JsonBody {unJsonBody :: a}
81+
82+instance A.ToJSON a => ToResponseBody (JsonBody a) where
83+ toBody (JsonBody a) = A.encode a
84+
85+instance A.FromJSON a => FromResponseBody (JsonBody a) where
86+ fromBody = fmap JsonBody . A.eitherDecode
87+
88+instance ToResponseBody ByteString where
89+ toBody = id
90+
91+instance FromResponseBody ByteString where
92+ fromBody = return
93+
94+instance ToResponseBody Text where
95+ toBody = BSL.fromStrict . T.encodeUtf8
96+
97+instance FromResponseBody Text where
98+ fromBody = first show . T.decodeUtf8' . BSL.toStrict
99+
100+class ServerError e where
101+ serverErrorStatus :: e -> Status
102+ serverErrorStatus _ = status422
103+
104+throwServerError ::
105+ (MonadError (ServerResponse ByteString) m, ServerError e, Show e) =>
106+ e ->
107+ m a
108+throwServerError e =
109+ throwError $
110+ defaultServerResponse
111+ { responseBody = Just . BSLC.pack . show $ e,
112+ responseStatus = serverErrorStatus e
113+ }
114+
115+type ResponseError = ServerResponse ByteString