[#26] Perform cosmetic refactoring (#33)

* Implement basic moving function dev476 issue

* Delete MoveUtil module

* Add -Wall to tests and executables

* Improve cosmetics of three-layer with successful build #26

* Remove redundant language import in App.Error - improve cosmetics of three-layer with successful build #26

* Add stylish haskell to certain .hs files

* Correct errors made in stylish haskell to certain .hs files

* Implement renaming and editing of package.yaml default-extensions issue #26

* Amend CI tests - implement renaming and editing of package.yaml default-extensions issue #26

* Edit stack.yaml and comment types in Lib.Db issue #26

* Clean up src files and test.Test.AuthSpec.hs file issue #26

* Remove redundant extensions and tidy up some functions in certain files issue #26

* Derive newtypes order and make new Lib.Core files issue #26

* Implement recently requested changes issue #26

* Add Makefile with ghcid command issue #26

* Patch fix-point to change three-layer in makefile issue #26

* Remove redundant lines and unlines functions in CopyFiles issue #26

* Make renameTL function point free in CopyFiles issue #26

* Change Lib.Core.Jwt with pattern match issue #26

Makefile

@@ -0,0 +1,2 @@
+ide:
+	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"

fix-point/src/CopyFiles.hs

@@ -37,8 +37,8 @@ copyAll source target newName = do
           copyFile sourcePath targetPath
           when (takeExtension sourcePath == ".hs") $
               R.contentRename R.rename (toText newName) targetPath
-          when (name == "package.yaml") $
-              R.contentRename renameYaml (toText newName) targetPath
+          when (toRenameFile name) $
+              R.contentRename renameTL (toText newName) targetPath
 
   where
     doesFileOrDirectoryExist :: FilePath -> IO Bool
@@ -48,5 +48,8 @@ copyAll source target newName = do
     wantedFiles x = not (x == "fix-point" || x == "three-layer.cabal" ||
                          x == ".git")
 
-renameYaml :: Text -> Text -> Text
-renameYaml new s = unlines [T.replace "three-layer" new x | x <- lines s]
+    toRenameFile :: FilePath -> Bool
+    toRenameFile x = x == "package.yaml" || x == "Makefile"
+
+renameTL :: Text -> Text -> Text
+renameTL = T.replace "three-layer"

package.yaml

@@ -35,6 +35,7 @@ dependencies:
 - ekg
 - ekg-core
 - elm-export
+- http-api-data
 - jwt
 - katip
 - monad-logger
@@ -47,19 +48,26 @@ dependencies:
 - servant
 - servant-generic
 - servant-server
+- text
 - time
 - universum
 - unordered-containers
 - uuid-types
 - warp
 
 default-extensions:
+- BangPatterns
+- DataKinds
 - DeriveGeneric
-- GeneralizedNewtypeDeriving
+- DerivingStrategies
 - FlexibleContexts
+- GeneralizedNewtypeDeriving
+- LambdaCase
 - OverloadedStrings
 - RecordWildCards
+- ScopedTypeVariables
 - TypeApplications
+- TypeOperators
 
 library:
   source-dirs: src
@@ -76,6 +84,7 @@ executables:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - three-layer
 
@@ -99,6 +108,7 @@ tests:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - hedgehog
     - three-layer

src/Lib.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE TypeApplications #-}
-
 module Lib
        ( mkAppEnv
        , runServer
@@ -9,8 +7,8 @@ import Network.Wai.Handler.Warp (run)
 import Servant.Server (serve)
 
 import Lib.App (AppEnv (..))
+import Lib.Core.Jwt (mkRandomString)
 import Lib.Server (API, server)
-import Lib.Util.JWT (mkRandomString)
 
 import qualified Data.HashMap.Strict as HashMap
 import qualified System.Metrics as Metrics

src/Lib/App.hs

@@ -10,12 +10,11 @@ import Control.Monad.Except (MonadError, throwError)
 import Katip (ColorStrategy (ColorIfTerminal), Katip, KatipContext, KatipContextT,
               Severity (DebugS), Verbosity (V2), closeScribes, defaultScribeSettings, initLogEnv,
               mkHandleScribe, registerScribe, runKatipContextT)
-import Servant.Server (Handler, err400, err401, err404, err500, errBody)
+import Servant.Server (Handler)
 
 import Lib.App.Env
-import Lib.App.Error (AppError (..))
+import Lib.App.Error (AppError (..), toHttpError)
 import Lib.Effects.Session (MonadSession)
-import Lib.Effects.User (MonadUser)
 
 -- TODO: inject logger configuration directly
 newtype App a = App
@@ -24,7 +23,6 @@ newtype App a = App
               MonadIO, Katip, KatipContext)
 
 instance MonadSession App
-instance MonadUser App
 
 runAppAsHandler :: AppEnv -> App a -> Handler a
 runAppAsHandler env action = do
@@ -41,9 +39,4 @@ runAppAsHandler env action = do
                $ runKatipContextT logEnv initialContext initialNamespace
                $ unApp action
 
-  case res of
-    Left (Invalid text)     -> throwError $ err400 { errBody = textToLBS text }
-    Left NotFound           -> throwError err404
-    Left (NotAllowed text)  -> throwError $ err401 { errBody = textToLBS text }
-    Left (ServerError text) -> throwError $ err500 { errBody = textToLBS text }
-    Right a                 -> return a
+  either (throwError . toHttpError) pure res

src/Lib/App/Error.hs

@@ -1,10 +1,112 @@
+{-# LANGUAGE ConstraintKinds #-}
+
 module Lib.App.Error
        ( AppError (..)
+       , WithError
+       , IError
+       , throwOnNothing
+       , notFoundOnNothing
+       , throwOnNothingM
+       , notFoundOnNothingM
+       , isServerError
+       , isNotAllowed
+       , isInvalid
+       , notFound
+       , serverError
+       , notAllowed
+       , invalid
+       , headerDecodeError
+       , jobDecodeError
+       , toHttpError
        ) where
 
-data AppError =
-    Invalid Text
-  | NotAllowed Text
-  | NotFound
-  | ServerError Text
-  deriving (Show, Eq)
+import Control.Monad.Except (MonadError, throwError)
+import Servant.Server (ServantErr, err401, err404, err417, err500, errBody)
+
+-- | Type alias for errors.
+type WithError m = MonadError AppError m
+
+newtype AppError = InternalError IError deriving (Show, Eq)
+
+data IError =
+    -- | General not found
+      NotFound
+    -- | Some exceptional circumstance has happened
+    -- stop execution and return. Optional text to
+    -- provide some context in server logs
+    | ServerError Text
+    -- | A required permission level was not met.
+    -- Optional text to provide some context.
+    | NotAllowed Text
+    -- | Given inputs do not conform to the expected
+    -- format or shape. Optional text to
+    -- provide some context in server logs
+    | Invalid Text
+    -- | An authentication header that was required
+    -- was provided but not in a format that the server
+    -- can understand
+    | HeaderDecodeError
+    | JobDecodeError Text
+    deriving (Show, Eq)
+
+isServerError :: AppError -> Bool
+isServerError (InternalError (ServerError _)) = True
+isServerError _                               = False
+
+isNotAllowed :: AppError -> Bool
+isNotAllowed (InternalError (NotAllowed _)) = True
+isNotAllowed _                              = False
+
+isInvalid :: AppError -> Bool
+isInvalid (InternalError (Invalid _)) = True
+isInvalid _                           = False
+
+----------------------------------------------------------------------------
+-- Internal Error helpers
+----------------------------------------------------------------------------
+
+notFound :: AppError
+notFound = InternalError NotFound
+
+serverError :: Text -> AppError
+serverError = InternalError . ServerError
+
+notAllowed :: Text -> AppError
+notAllowed = InternalError . NotAllowed
+
+invalid :: Text -> AppError
+invalid = InternalError . Invalid
+
+headerDecodeError :: AppError
+headerDecodeError = InternalError HeaderDecodeError
+
+jobDecodeError :: Text -> AppError
+jobDecodeError = InternalError . JobDecodeError
+
+throwOnNothing :: WithError m => AppError -> Maybe a -> m a
+throwOnNothing err = maybe (throwError err) pure
+
+-- | Extract the value from a maybe, throwing the given 'AppError' if
+-- the value does not exist
+throwOnNothingM :: (WithError m) => AppError -> m (Maybe a) -> m a
+throwOnNothingM err action = action >>= throwOnNothing err
+
+-- | Similar to 'throwOnNothing' but throws a 'NotFound' if the value does not exist
+notFoundOnNothing :: WithError m => Maybe a -> m a
+notFoundOnNothing = throwOnNothing notFound
+
+-- | Extract a value from a maybe, throwing a 'NotFound' if  the value
+-- does not exist
+notFoundOnNothingM :: (WithError m) => m (Maybe a) -> m a
+notFoundOnNothingM = throwOnNothingM notFound
+
+toHttpError :: AppError -> ServantErr
+toHttpError = \case
+  InternalError err ->
+    case err of
+      NotFound          -> err404
+      ServerError msg   -> err500 { errBody = encodeUtf8 msg }
+      NotAllowed msg    -> err401 { errBody = encodeUtf8 msg }
+      Invalid msg       -> err417 { errBody = encodeUtf8 msg }
+      HeaderDecodeError -> err401 { errBody = "Unable to decode header" }
+      JobDecodeError er -> err401 { errBody = encodeUtf8 er }

src/Lib/Core/Admin.hs

@@ -0,0 +1,27 @@
+module Lib.Core.Admin
+       ( Admin (..)
+       ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)
+
+import Lib.Core.Email (Email)
+import Lib.Core.Id (Id)
+import Lib.Core.Password (PasswordHash)
+
+-- | Admin user inside Lib platform.
+data Admin = Admin
+    { adminId    :: Id Admin
+    , adminEmail :: Email
+    , adminHash  :: PasswordHash
+    } deriving (Generic)
+
+instance ToJSON Admin
+instance FromJSON Admin
+
+instance FromRow Admin where
+    fromRow = do
+        adminId <- field
+        adminEmail <- field
+        adminHash <- field
+        pure Admin{..}

src/Lib/Core/Email.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE DeriveAnyClass     #-}
+
+module Lib.Core.Email
+       ( Email (..)
+       ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Database.PostgreSQL.Simple.FromField (FromField)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Elm (ElmType)
+
+newtype Email = Email { unEmail :: Text }
+    deriving stock (Show, Generic)
+    deriving newtype (Eq, Ord, Hashable, FromField, ToField)
+    deriving anyclass (FromJSON, ToJSON, ElmType)

src/Lib/Core/Id.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DeriveAnyClass     #-}
+
+-- | Contains newtype safe wrappers.
+
+module Lib.Core.Id
+       ( -- * Id
+         Id (..)
+       , AnyId
+       , castId
+       ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Database.PostgreSQL.Simple.FromField (FromField)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Elm (ElmType)
+import Web.HttpApiData (FromHttpApiData)
+
+-- | Wrapper for textual id. Contains phantom type parameter for increased type-safety.
+newtype Id a = Id { unId :: Text }
+    deriving stock (Show, Generic)
+    deriving newtype (Eq, Ord, Hashable, FromField, ToField, FromHttpApiData)
+    deriving anyclass (FromJSON, ToJSON, ElmType)
+
+-- | When we don't care about type of 'Id' but don't want to deal with type variables
+type AnyId = Id ()
+
+-- | Unsafe cast of 'Id'. Use with explicit TypeApplication.
+castId :: forall to from . Id from -> Id to
+castId (Id a) = Id a

src/Lib/Util/JWT.hs → src/Lib/Core/Jwt.hs

@@ -1,4 +1,4 @@
-module Lib.Util.JWT
+module Lib.Core.Jwt
        ( JWTPayload (..)
        , jwtPayloadToMap
        , jwtPayloadFromMap
@@ -33,11 +33,8 @@ jwtPayloadToMap JWTPayload{..} = Map.fromList [("id", String $ UUID.toText jwtUs
 
 jwtPayloadFromMap :: Map Text Value -> Maybe JWTPayload
 jwtPayloadFromMap claimsMap = do
-  idVal <- Map.lookup "id" claimsMap
-  mJwtId <- case idVal of
-    String jwtId -> return jwtId
-    _            -> Nothing
-  jwtUserId <- UUID.fromText mJwtId
+  String jwtId <- Map.lookup "id" claimsMap
+  jwtUserId <- UUID.fromText jwtId
   return JWTPayload{..}
 
 mkJWTToken :: (MonadIO m, MonadReader AppEnv m) => Int -> JWTPayload -> m Text