[#26] Continue cosmetic refactoring (#34)

* Add newtype Seconds to new Lib.Time module and refactor functions that need it so far issue #26

* Amend CI test problems issue #26

* Implement pattern matching in Lib.Core.Jwt.hs issue #26

* Refactor JwtSpec and PasswordSpec issue #26

* Remove JwtSpec.hs temporarily issue #26

* Add JwtSpec.hs back issue #26

* Add ekg issue #26

* Polish JwtSpec and Password issue #26

* Moving of import to hackage dependencies section issue #26

* Re-commit to get CI tests to work issue #26

* Add Date data type to protobuf issue #26

* Add Proto.Login_Fields to package.yaml issue #26

* Implement requested changes with Core.Jwt.hs, Time.hs and app.Main.hs files issue #26

* Amend requested changes issue #26

* Fix CI test errors - Amend requested changes issue #26

* Minor issue fix - Amend requested changes issue #26

* Amend CI tests on minor issue fix - Amend requested changes issue #26

* Move JwtToken ElmType instance to Lib.Core.Jwt.hs file issue #26

app/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import           Lib
+import qualified Lib
 
 main :: IO ()
-main = mkAppEnv >>= runServer
+main = Lib.main

fix-point/app/Main.hs

@@ -2,12 +2,11 @@ module Main where
 
 import Universum
 
-import Data.Char (toUpper, toLower)
+import Data.Char (toLower, toUpper)
 import Data.Maybe (maybe)
 import Data.Semigroup ((<>))
-import Options.Applicative (Parser, long, metavar, help, helper, progDesc,
-                            fullDesc, header, info, (<**>), execParser,
-                            strArgument, strOption)
+import Options.Applicative (Parser, execParser, fullDesc, header, help, helper, info, long, metavar,
+                            progDesc, strArgument, strOption, (<**>))
 import System.Directory (doesDirectoryExist, getCurrentDirectory)
 
 import CopyFiles (copyAll)
@@ -30,11 +29,11 @@ bootstrap (Options project pref source) = do
   where
     upperHead :: String -> String
     upperHead (start:body) = toUpper start : body
-    upperHead [] = []
+    upperHead []           = []
 
 data Options = Options
-    { projectName :: String
-    , prefixName :: Maybe String
+    { projectName     :: String
+    , prefixName      :: Maybe String
     , sourceDirectory :: Maybe String
     }
 

fix-point/src/CopyFiles.hs

@@ -4,9 +4,9 @@ import Universum
 
 import Control.Exception (throw)
 import Data.Text (Text)
-import System.Directory (copyFile, createDirectory, doesDirectoryExist,
-                         doesFileExist, listDirectory)
-import System.FilePath ((</>), takeExtension)
+import System.Directory (copyFile, createDirectory, doesDirectoryExist, doesFileExist,
+                         listDirectory)
+import System.FilePath (takeExtension, (</>))
 import System.IO.Error (userError)
 
 import qualified Data.Text as T

generate-elm/Main.hs

@@ -1,8 +1,4 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE KindSignatures #-}
 
 module Main where
 

package.yaml

@@ -9,7 +9,7 @@ copyright:           "2018 Holmusk"
 extra-source-files:
 - README.md
 - ChangeLog.md
-- proto/login.proto
+- proto/*
 
 # Metadata used when publishing your package
 # synopsis:            Short description of your package
@@ -74,7 +74,10 @@ library:
   ghc-options:
   - -Wall
   other-modules:
+    - Proto.Common
+    - Proto.Common_Fields
     - Proto.Login
+    - Proto.Login_Fields
 
 executables:
   three-layer-exe:

proto/common.proto

@@ -0,0 +1,26 @@
+syntax = "proto2";
+
+message Date {
+  // Year of date. Must be from 1 to 9999, or 0 if specifying a date without
+  // a year.
+  required int32 year = 1;
+
+  // Month of year. Must be from 1 to 12.
+  required int32 month = 2;
+
+  // Day of month. Must be from 1 to 31 and valid for the year and month, or 0
+  // if specifying a year/month where the day is not significant.
+  required int32 day = 3;
+}
+
+message Timestamp {
+  // Represents the seconds elapsed in the day since 00:00
+  required int64 seconds = 1;
+  // Number of nanoseconds elapsed that second
+  required int32 nanos = 2 [default = 0];
+}
+
+message Datetime {
+  required Date date = 1;
+  required Timestamp timestamp = 2;
+}

src/Lib.hs

@@ -1,12 +1,14 @@
 module Lib
        ( mkAppEnv
        , runServer
+       , main
        ) where
 
 import Network.Wai.Handler.Warp (run)
 import Servant.Server (serve)
+import System.Remote.Monitoring (forkServerWith)
 
-import Lib.App (AppEnv (..))
+import Lib.App (AppEnv (..), JwtSecret (..))
 import Lib.Core.Jwt (mkRandomString)
 import Lib.Server (API, server)
 
@@ -17,13 +19,19 @@ mkAppEnv :: IO AppEnv
 mkAppEnv = do
   let dbPool = error "Not implemented yet"
   sessions <- newMVar HashMap.empty
-  jwtSecret <- mkRandomString 10
+  randTxt <- mkRandomString 10
+  let jwtSecret = JwtSecret randTxt
   timings <- newIORef HashMap.empty
   ekgStore <- Metrics.newStore
   Metrics.registerGcMetrics ekgStore
   return AppEnv{..}
 
 runServer :: AppEnv -> IO ()
-runServer env = run 8080 application
+runServer env = do
+    () <$ forkServerWith (ekgStore env) "localhost" 8081
+    run 8081 application
   where
-  application = serve (Proxy @API) (server env)
+    application = serve (Proxy @API) (server env)
+
+main :: IO ()
+main = mkAppEnv >>= runServer

src/Lib/App/Env.hs

@@ -1,22 +1,28 @@
 module Lib.App.Env
        ( AppEnv (..)
+       , JwtSecret (..)
        , Session (..)
        ) where
 
 import Data.Pool (Pool)
 import Data.UUID.Types (UUID)
 import Database.PostgreSQL.Simple (Connection)
+
 import System.Metrics (Store)
 import System.Metrics.Distribution (Distribution)
 
 data AppEnv = AppEnv
   { dbPool    :: Pool Connection
   , sessions  :: MVar (HashMap UUID Session)
-  , jwtSecret :: Text
+  , jwtSecret :: JwtSecret
   , timings   :: IORef (HashMap Text Distribution)
   , ekgStore  :: Store
   }
 
 newtype Session = Session {
   isLoggedIn :: Bool
 }
+
+newtype JwtSecret = JwtSecret {
+  unJwtSecret :: Text
+}

src/Lib/Core/Jwt.hs

@@ -1,19 +1,28 @@
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DerivingStrategies #-}
+
 module Lib.Core.Jwt
-       ( JWTPayload (..)
+       ( JwtPayload (..)
+       , JwtToken (..)
        , jwtPayloadToMap
        , jwtPayloadFromMap
-       , decodeAndVerifyJWTToken
-       , mkJWTToken
+       , decodeAndVerifyJwtToken
+       , mkJwtToken
        , mkRandomString
        ) where
 
-import Data.Aeson (Value (..))
+import Data.Aeson (FromJSON, ToJSON, Value (..))
 import Data.Map (Map)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.UUID.Types (UUID)
+import Database.PostgreSQL.Simple.FromField (FromField)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Elm (ElmType)
 import System.Random (newStdGen, randomRs)
+import Web.HttpApiData (FromHttpApiData)
 
-import Lib.App.Env (AppEnv (..))
+import Lib.App.Env (AppEnv (..), JwtSecret (..))
+import Lib.Time (Seconds (..))
 
 import qualified Data.Map as Map
 import qualified Data.UUID.Types as UUID
@@ -24,36 +33,43 @@ import qualified Web.JWT as JWT
 mkRandomString :: (MonadIO m) => Int -> m Text
 mkRandomString len = toText . take len . randomRs ('a', 'z') <$> liftIO newStdGen
 
-newtype JWTPayload = JWTPayload {
+instance ElmType JwtToken
+
+newtype JwtPayload = JwtPayload {
   jwtUserId :: UUID
 } deriving (Eq, Show)
 
-jwtPayloadToMap :: JWTPayload -> Map Text Value
-jwtPayloadToMap JWTPayload{..} = Map.fromList [("id", String $ UUID.toText jwtUserId)]
+newtype JwtToken = JwtToken { unJwtToken :: Text }
+    deriving stock (Show, Generic)
+    deriving newtype (Eq, Ord, Hashable, FromField, ToField, FromHttpApiData)
+    deriving anyclass (FromJSON, ToJSON)
+
+jwtPayloadToMap :: JwtPayload -> Map Text Value
+jwtPayloadToMap JwtPayload{..} = Map.fromList [("id", String $ UUID.toText jwtUserId)]
 
-jwtPayloadFromMap :: Map Text Value -> Maybe JWTPayload
+jwtPayloadFromMap :: Map Text Value -> Maybe JwtPayload
 jwtPayloadFromMap claimsMap = do
   String jwtId <- Map.lookup "id" claimsMap
   jwtUserId <- UUID.fromText jwtId
-  return JWTPayload{..}
+  return JwtPayload{..}
 
-mkJWTToken :: (MonadIO m, MonadReader AppEnv m) => Int -> JWTPayload -> m Text
-mkJWTToken expiryInSeconds payload = do
-  secret <- JWT.secret <$> asks jwtSecret
+mkJwtToken :: (MonadIO m, MonadReader AppEnv m) => Seconds -> JwtPayload -> m JwtToken
+mkJwtToken (Seconds expiry) payload = do
+  secret <- JWT.secret <$> asks (unJwtSecret . jwtSecret)
   timeNow <- liftIO getPOSIXTime
-  let expiryTime = timeNow + fromIntegral expiryInSeconds
+  let expiryTime = timeNow + fromIntegral expiry
   let claimsSet = JWT.def {
     JWT.exp = JWT.numericDate expiryTime,
     JWT.unregisteredClaims = jwtPayloadToMap payload
   }
-  return $ JWT.encodeSigned JWT.HS256 secret claimsSet
+  return $ JwtToken (JWT.encodeSigned JWT.HS256 secret claimsSet)
 
-decodeAndVerifyJWTToken :: (MonadIO m, MonadReader AppEnv m) => Text -> m (Maybe JWTPayload)
-decodeAndVerifyJWTToken token = do
-  secret <- JWT.secret <$> asks jwtSecret
+decodeAndVerifyJwtToken :: (MonadIO m, MonadReader AppEnv m) => JwtToken -> m (Maybe JwtPayload)
+decodeAndVerifyJwtToken token = do
+  secret <- JWT.secret <$> asks (unJwtSecret . jwtSecret)
   timeNow <- JWT.numericDate <$> liftIO getPOSIXTime
   pure $ do
-    claimsSet <- JWT.claims <$> JWT.decodeAndVerifySignature secret token
+    claimsSet <- JWT.claims <$> JWT.decodeAndVerifySignature secret (unJwtToken token)
     (now, expiryTimeStatedInToken) <- (,) <$> timeNow <*> JWT.exp claimsSet
     guard (expiryTimeStatedInToken >= now)
     jwtPayloadFromMap $ JWT.unregisteredClaims claimsSet

src/Lib/Db.hs

@@ -22,7 +22,7 @@ type WithDbPool m = (MonadReader AppEnv m, MonadIO m)
 query :: (WithDbPool m, SQL.ToRow q, SQL.FromRow r) => SQL.Query -> q -> m [r]
 query qx args = perform (\conn -> SQL.query conn qx args)
 
--- | Query the database with a given query and no args and expect a list
+-- | Query database with a given query and no args and expect a list
 -- of rows in return
 query_ :: (WithDbPool m, SQL.FromRow r) => SQL.Query -> m [r]
 query_ qx = perform (`SQL.query_` qx)

src/Lib/Server/Auth.hs

@@ -19,11 +19,12 @@ import Servant.Generic ((:-), AsApi, AsServerT, ToServant)
 
 import Lib.App (App, AppError (..), Session (..))
 import Lib.App.Error (notAllowed, notFound, throwOnNothingM)
-import Lib.Core.Jwt (JWTPayload (..), decodeAndVerifyJWTToken, mkJWTToken)
+import Lib.Core.Jwt (JwtPayload (..), JwtToken (..), decodeAndVerifyJwtToken, mkJwtToken)
 import Lib.Core.Password (PasswordPlainText (..), verifyPassword)
 import Lib.Effects.Measure (timedAction)
 import Lib.Effects.Session (MonadSession (..))
 import Lib.Effects.User (MonadUser (..), User (..))
+import Lib.Time (dayInSeconds)
 
 data LoginRequest = LoginRequest
   { loginRequestEmail    :: Text
@@ -35,7 +36,7 @@ instance FromJSON LoginRequest
 instance ToJSON LoginRequest
 
 newtype LoginResponse = LoginResponse
-  { loginResponseToken :: Text
+  { loginResponseToken :: JwtToken
   } deriving (Generic, Show, Eq)
 
 instance ElmType LoginResponse
@@ -49,10 +50,10 @@ data AuthSite route = AuthSite
 
     -- | Check if a given JWT is valid
   , loginJWT :: route :-
-      "login" :> Capture "JWT" Text :> Get '[JSON] NoContent
+      "login" :> Capture "JWT" JwtToken :> Get '[JSON] NoContent
 
   , logout :: route :-
-      "logout" :> Capture "JWT" Text :> Get '[JSON] NoContent
+      "logout" :> Capture "JWT" JwtToken :> Get '[JSON] NoContent
   } deriving (Generic)
 
 type AuthAPI = ToServant (AuthSite AsApi)
@@ -76,23 +77,23 @@ loginHandler LoginRequest{..} = timedAction "loginHandler" $ do
     $(logTM) DebugS $ ls $ "Incorrect password for user " <> loginRequestEmail
     throwError (notAllowed "Invalid Password")
   putSession userId Session { isLoggedIn = True }
-  token <- mkJWTToken (60 * 60 * 24) (JWTPayload userId)
+  token <- mkJwtToken dayInSeconds (JwtPayload userId)
   return $ LoginResponse token
 
-isLoggedInHandler :: (MonadSession m, MonadError AppError m) => Text -> m NoContent
+isLoggedInHandler :: (MonadSession m, MonadError AppError m) => JwtToken -> m NoContent
 isLoggedInHandler token = timedAction "isLoggedInHandler" $ do
-  JWTPayload{..} <- throwOnNothingM (notAllowed "Invalid Token") $ decodeAndVerifyJWTToken token
+  JwtPayload{..} <- throwOnNothingM (notAllowed "Invalid Token") $ decodeAndVerifyJwtToken token
   Session{..} <- throwOnNothingM (notAllowed "Expired Session") $ getSession jwtUserId
   unless isLoggedIn $ throwError (notAllowed "Revoked Session")
   return NoContent
 
-logoutHandler :: (MonadSession m, KatipContext m) => Text -> m NoContent
+logoutHandler :: (MonadSession m, KatipContext m) => JwtToken -> m NoContent
 logoutHandler token = timedAction "logoutHandler" $ do
-  mPayload <- decodeAndVerifyJWTToken token
+  mPayload <- decodeAndVerifyJwtToken token
   case mPayload of
-    Just JWTPayload{..} -> do
+    Just JwtPayload{..} -> do
       deleteSession jwtUserId
       return NoContent
     Nothing -> do
-      $(logTM) DebugS $ ls $ token <> " was used to logout when it was invalid"
+      $(logTM) DebugS $ ls $ unJwtToken token <> " was used to logout when it was invalid"
       return NoContent