Skip to content

Commit f569347

Browse files
chshershchshersh
authored
[Holmusk#58] Switch to better SQL integration (Holmusk#62)
* [Holmusk#58] Switch to better SQL integration Resolves Holmusk#58 * Fix tests, rewrute tests
1 parent e08e56a commit f569347

23 files changed

+543
-304
lines changed

‎.circleci/config.yml

+4
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,10 @@ jobs:
33
build-and-test-backend:
44
docker:
55
- image: holmusk/haskell-ci
6+
- image: circleci/postgres:10-alpine-ram
7+
environment:
8+
POSTGRES_USER: root
9+
POSTGRES_DB: three-layer
610
steps:
711
- checkout
812
- restore-cache:

‎Makefile

+6
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,8 @@
11
ide:
22
ghcid --command "stack ghci --ghci-options=-fno-code --main-is three-layer:generate-elm three-layer:lib three-layer:exe:three-layer-exe three-layer:test:three-layer-test"
3+
4+
postgres:
5+
docker run -p 5432\:5432 -e POSTGRES_USER=root -e POSTGRES_DB=three-layer postgres\:10.5-alpine
6+
7+
sql-repl:
8+
psql -h localhost -p 5432 -U root -d three-layer

‎sql/drop.sql

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
DROP TABLE IF EXISTS users CASCADE;

‎sql/schema.sql

+13
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
-- To execute this file from SQL REPL:
2+
-- \i sql/schema.sql
3+
4+
CREATE TABLE IF NOT EXISTS users
5+
( id TEXT NOT NULL
6+
, email TEXT NOT NULL
7+
, name TEXT NOT NULL
8+
, pwd_hash TEXT NOT NULL
9+
, created_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT NOW()
10+
);
11+
12+
ALTER TABLE ONLY users
13+
ADD CONSTRAINT pk_users PRIMARY KEY (id);

‎sql/seed.sql

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
-- seed SQL file used for testing purposes
2+
3+
-- inserts manager with the name 'admin' and hash of the password '123'
4+
INSERT INTO users (id, email, name, pwd_hash)
5+
VALUES ('id1', 'test@test.com', 'User Userov', '$2y$14$dkHVYLbmnTTeT8DUuAsM5uOz7djmrcuzUv5jXurxveUk0vRca/AqW');

‎src/Lib.hs

+8-4
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ import System.Remote.Monitoring (forkServerWith)
1010

1111
import Lib.App (AppEnv, Env (..))
1212
import Lib.Core.Jwt (JwtSecret (..), mkRandomString)
13+
import Lib.Db (initialisePool)
1314
import Lib.Effects.Log (mainLogAction)
1415
import Lib.Server (API, server)
1516

@@ -18,12 +19,15 @@ import qualified System.Metrics as Metrics
1819

1920
mkAppEnv :: IO AppEnv
2021
mkAppEnv = do
21-
let envDbPool = error "Not implemented yet"
22+
-- IO configuration
23+
envDbPool <- initialisePool
2224
envSessions <- newMVar HashMap.empty
23-
randTxt <- mkRandomString 10
24-
let envJwtSecret = JwtSecret randTxt
25-
envTimings <- newIORef HashMap.empty
25+
envTimings <- newIORef HashMap.empty
2626
envEkgStore <- Metrics.newStore
27+
randTxt <- mkRandomString 10
28+
let envJwtSecret = JwtSecret randTxt
29+
30+
-- pure configuration
2731
let envSessionExpiry = 600
2832
let envLogAction = mainLogAction D
2933
pure Env{..}

‎src/Lib/App/Env.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,7 @@ type DbPool = Pool Connection
2525
type Timings = IORef (HashMap Text Distribution)
2626

2727
data Env (m :: Type -> Type) = Env
28-
{ envDbPool :: DbPool
28+
{ envDbPool :: !DbPool
2929
, envSessions :: !Sessions
3030
, envJwtSecret :: !JwtSecret
3131
, envTimings :: !Timings

‎src/Lib/App/Error.hs

+139-55
Original file line numberDiff line numberDiff line change
@@ -4,21 +4,26 @@
44

55
module Lib.App.Error
66
( AppError (..)
7+
, AppErrorType
78
, AppException (..)
89
, WithError
9-
, IError
10+
, throwError
11+
, toHttpError
1012

11-
-- * Internal error helpers
13+
-- * Error checks
1214
, isServerError
1315
, isNotAllowed
1416
, isInvalid
17+
18+
-- * Internal error helpers
1519
, notFound
1620
, serverError
1721
, notAllowed
1822
, invalid
23+
, missingHeader
1924
, headerDecodeError
20-
, jobDecodeError
21-
, toHttpError
25+
, dbError
26+
, limitError
2227

2328
-- * Error throwing helpers
2429
, throwOnNothing
@@ -27,13 +32,41 @@ module Lib.App.Error
2732
, notFoundOnNothingM
2833
) where
2934

30-
import Control.Monad.Except (MonadError, throwError)
31-
import Servant.Server (ServerError, err401, err404, err417, err500, errBody)
35+
import Control.Monad.Except (MonadError)
36+
import Data.CaseInsensitive (foldedCase)
37+
import GHC.Stack (SrcLoc (SrcLoc, srcLocModule, srcLocStartLine))
38+
import Network.HTTP.Types.Header (HeaderName)
39+
import Servant.Server (err401, err404, err413, err417, err500, errBody)
40+
41+
import qualified Control.Monad.Except as E (throwError)
42+
import qualified Servant.Server as Servant (ServerError)
3243

3344

3445
-- | Type alias for errors.
3546
type WithError m = MonadError AppError m
3647

48+
-- | Specialized version of 'E.throwError'
49+
throwError :: WithError m => AppErrorType -> m a
50+
throwError = E.throwError . AppError (toSourcePosition callStack)
51+
{-# INLINE throwError #-}
52+
53+
newtype SourcePosition = SourcePosition Text
54+
deriving newtype (Show, Eq)
55+
56+
-- | Display 'CallStack' as 'SourcePosition' in a format: @Module.function#line_number@.
57+
toSourcePosition :: CallStack -> SourcePosition
58+
toSourcePosition cs = SourcePosition showCallStack
59+
where
60+
showCallStack :: Text
61+
showCallStack = case getCallStack cs of
62+
[] -> "<unknown loc>"
63+
[(name, loc)] -> showLoc name loc
64+
(_, loc) : (callerName, _) : _ -> showLoc callerName loc
65+
66+
showLoc :: String -> SrcLoc -> Text
67+
showLoc name SrcLoc{..} =
68+
toText srcLocModule <> "." <> toText name <> "#" <> show srcLocStartLine
69+
3770
{- | Exception wrapper around 'AppError'. Useful when you need to throw/catch
3871
'AppError' as 'Exception'.
3972
-}
@@ -42,93 +75,144 @@ newtype AppException = AppException
4275
} deriving (Show)
4376
deriving anyclass (Exception)
4477

78+
-- | 'HaiaErrorType' with the corresponding 'CallStack'.
79+
data AppError = AppError
80+
{ appErrorCallStack :: !SourcePosition
81+
, appErrorType :: !AppErrorType
82+
} deriving (Show, Eq)
83+
4584
-- | App errors type.
46-
newtype AppError = InternalError IError
85+
newtype AppErrorType = InternalError IError
4786
deriving (Show, Eq)
4887

49-
-- | App internal errors.
50-
data IError =
51-
-- | General not found
52-
NotFound
53-
-- | Some exceptional circumstance has happened
54-
-- stop execution and return. Optional text to
55-
-- provide some context in server logs
88+
{- | The internal errors that can be thrown. These errors are meant to be
89+
handled within Haia and cover exceptional circumstances/coding errors.
90+
-}
91+
data IError
92+
{- | General not found. -}
93+
= NotFound
94+
{- | Some exceptional circumstance has happened stop execution and return.
95+
Optional text to provide some context in server logs.
96+
-}
5697
| ServerError Text
57-
-- | A required permission level was not met.
58-
-- Optional text to provide some context.
98+
{- | A required permission level was not met. Optional text to provide some context. -}
5999
| NotAllowed Text
60-
-- | Given inputs do not conform to the expected
61-
-- format or shape. Optional text to
62-
-- provide some context in server logs
100+
{- | Given inputs do not conform to the expected format or shape. Optional
101+
text to provide some context in server logs.
102+
-}
63103
| Invalid Text
64-
-- | An authentication header that was required
65-
-- was provided but not in a format that the server
66-
-- can understand
67-
| HeaderDecodeError
68-
| JobDecodeError Text
104+
{- | Some header expected, but not present in header list.
105+
-}
106+
| MissingHeader HeaderName
107+
{- | An authentication header that was required was provided but not in a
108+
format that the server can understand
109+
-}
110+
| HeaderDecodeError Text
111+
-- | Data base specific errors
112+
| DbError Text
113+
-- | Limits on the multi-request are overflowed.
114+
| LimitError
69115
deriving (Show, Eq)
70116

71-
isServerError :: AppError -> Bool
117+
-- | Map 'AppError' into a HTTP error code.
118+
toHttpError :: AppError -> Servant.ServerError
119+
toHttpError (AppError _callStack errorType) = case errorType of
120+
InternalError err -> case err of
121+
NotFound -> err404
122+
ServerError msg -> err500 { errBody = encodeUtf8 msg }
123+
NotAllowed msg -> err401 { errBody = encodeUtf8 msg }
124+
Invalid msg -> err417 { errBody = encodeUtf8 msg }
125+
MissingHeader name -> err401 { errBody = toLazy $ "Header not found: " <> foldedCase name }
126+
HeaderDecodeError name -> err401 { errBody = encodeUtf8 $ "Unable to decode header: " <> name }
127+
DbError e -> err500 { errBody = encodeUtf8 e }
128+
LimitError -> err413 { errBody = "Request is over the limits"}
129+
-- MobileAppError err -> let errMsg = Proto.ErrorResponse err mempty in
130+
-- err400 { errBody = fromStrict $ encodeMessage errMsg }
131+
-- ExternalError err -> case err of
132+
-- ClientError e -> clientErrortoServantErr e
133+
-- -- _ -> err400 { errBody = "External error" }
134+
135+
136+
-- clientErrortoServantErr :: ServantError -> Servant.ServerError
137+
-- clientErrortoServantErr = \case
138+
-- -- The server returned an error response
139+
-- FailureResponse response ->
140+
-- err500 { errBody = show response }
141+
-- -- The body could not be decoded at the expected type
142+
-- DecodeFailure txt response ->
143+
-- err500 { errBody = encodeUtf8 txt <> show response }
144+
-- -- The content-type of the response is not supported
145+
-- UnsupportedContentType mediaType response ->
146+
-- err415 { errBody = show mediaType <> show response }
147+
-- -- The content-type header is invalid
148+
-- InvalidContentTypeHeader response ->
149+
-- err401 { errBody = show response }
150+
-- -- There was a connection error, and no response was received
151+
-- ConnectionError txt ->
152+
-- err503 { errBody = encodeUtf8 txt }
153+
154+
----------------------------------------------------------------------------
155+
-- Error checks
156+
----------------------------------------------------------------------------
157+
158+
isServerError :: AppErrorType -> Bool
72159
isServerError (InternalError (ServerError _)) = True
73160
isServerError _ = False
74161

75-
isNotAllowed :: AppError -> Bool
162+
isNotAllowed :: AppErrorType -> Bool
76163
isNotAllowed (InternalError (NotAllowed _)) = True
77164
isNotAllowed _ = False
78165

79-
isInvalid :: AppError -> Bool
166+
isInvalid :: AppErrorType -> Bool
80167
isInvalid (InternalError (Invalid _)) = True
81168
isInvalid _ = False
82169

83170
----------------------------------------------------------------------------
84171
-- Internal Error helpers
85172
----------------------------------------------------------------------------
86173

87-
notFound :: AppError
174+
notFound :: AppErrorType
88175
notFound = InternalError NotFound
89176

90-
serverError :: Text -> AppError
177+
serverError :: Text -> AppErrorType
91178
serverError = InternalError . ServerError
92179

93-
notAllowed :: Text -> AppError
180+
notAllowed :: Text -> AppErrorType
94181
notAllowed = InternalError . NotAllowed
95182

96-
invalid :: Text -> AppError
183+
invalid :: Text -> AppErrorType
97184
invalid = InternalError . Invalid
98185

99-
headerDecodeError :: AppError
100-
headerDecodeError = InternalError HeaderDecodeError
186+
missingHeader :: HeaderName -> AppErrorType
187+
missingHeader = InternalError . MissingHeader
101188

102-
jobDecodeError :: Text -> AppError
103-
jobDecodeError = InternalError . JobDecodeError
189+
headerDecodeError :: Text -> AppErrorType
190+
headerDecodeError = InternalError . HeaderDecodeError
191+
192+
dbError :: Text -> AppErrorType
193+
dbError = InternalError . DbError
194+
195+
limitError :: AppErrorType
196+
limitError = InternalError LimitError
104197

105198
----------------------------------------------------------------------------
106199
-- Helpers
107200
----------------------------------------------------------------------------
108201

109-
throwOnNothing :: WithError m => AppError -> Maybe a -> m a
110-
throwOnNothing err = maybe (throwError err) pure
202+
-- | Extract the value from a maybe, throwing the given 'HaiaError' if
203+
-- the value does not exist
204+
throwOnNothing :: WithError m => AppErrorType -> Maybe a -> m a
205+
throwOnNothing err = withFrozenCallStack . maybe (throwError err) pure
111206

112-
-- | Extract the value from a maybe, throwing the given 'AppError' if
207+
-- | Extract the value from a 'Maybe' in @m@, throwing the given 'HaiaError' if
113208
-- the value does not exist
114-
throwOnNothingM :: (WithError m) => AppError -> m (Maybe a) -> m a
115-
throwOnNothingM err action = action >>= throwOnNothing err
209+
throwOnNothingM :: WithError m => AppErrorType -> m (Maybe a) -> m a
210+
throwOnNothingM err action = withFrozenCallStack $ action >>= throwOnNothing err
116211

117212
-- | Similar to 'throwOnNothing' but throws a 'NotFound' if the value does not exist
118213
notFoundOnNothing :: WithError m => Maybe a -> m a
119-
notFoundOnNothing = throwOnNothing notFound
214+
notFoundOnNothing = withFrozenCallStack . throwOnNothing notFound
120215

121-
-- | Extract a value from a maybe, throwing a 'NotFound' if the value
122-
-- does not exist
123-
notFoundOnNothingM :: (WithError m) => m (Maybe a) -> m a
124-
notFoundOnNothingM = throwOnNothingM notFound
125-
126-
toHttpError :: AppError -> ServerError
127-
toHttpError = \case
128-
InternalError err -> case err of
129-
NotFound -> err404
130-
ServerError msg -> err500 { errBody = encodeUtf8 msg }
131-
NotAllowed msg -> err401 { errBody = encodeUtf8 msg }
132-
Invalid msg -> err417 { errBody = encodeUtf8 msg }
133-
HeaderDecodeError -> err401 { errBody = "Unable to decode header" }
134-
JobDecodeError er -> err401 { errBody = encodeUtf8 er }
216+
-- | Similar to 'throwOnNothingM' but throws a 'NotFound' if the value does not exist
217+
notFoundOnNothingM :: WithError m => m (Maybe a) -> m a
218+
notFoundOnNothingM = withFrozenCallStack . throwOnNothingM notFound

‎src/Lib/Core/Password.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ module Lib.Core.Password
77
, verifyPassword
88
) where
99

10-
import Lib.App.Error (WithError, AppError, serverError, throwOnNothingM)
10+
import Lib.App.Error (WithError, AppErrorType, serverError, throwOnNothingM)
1111

1212
import qualified Crypto.BCrypt as BC
1313

@@ -45,7 +45,7 @@ mkPasswordHashWithPolicy hashPolicy password = throwOnNothingM errorMessage hash
4545
hashText :: m (Maybe PasswordHash)
4646
hashText = PasswordHash . decodeUtf8 <<$>> hashBS
4747

48-
errorMessage :: AppError
48+
errorMessage :: AppErrorType
4949
errorMessage = serverError "Error generating password hash"
5050

5151
-- | Generates the password hash with slow hashing policy.

0 commit comments

Comments
 (0)