wip

ebook-manager.cabal

@@ -73,6 +73,7 @@ executable ebook-manager
                      , servant-server
                      , text
                      , transformers
+                     , uuid
                      , wai
                      , warp
                      , x509

migrations/V1.2__User_token.sql

@@ -0,0 +1 @@
+alter table users add column token text null;

src/API/Books.hs

@@ -55,7 +55,7 @@ instance FromJSON JsonBook
 instance ToJSON PostBook
 instance FromJSON PostBook
 
-type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
+type API = Auth '[TokenCheck, SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
 
 type BaseAPI = "books" :> Get '[JSON] [JsonBook]
        :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook

src/API/Users.hs

@@ -5,6 +5,8 @@
 {-# Language TypeOperators #-}
 {-# Language DuplicateRecordFields #-}
 {-# Language TypeApplications #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+{-# Language NamedFieldPuns #-}
 module API.Users  where
 
 import Servant
@@ -40,12 +42,16 @@ instance FromJSON RegisterStatus
 instance FromForm RegisterForm
 instance ToForm RegisterForm
 
-
 type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus
       :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
+      :<|> Auth '[SA.BasicAuth] SafeUser :> "token" :> Post '[JSON, PlainText] Token
 
 handler :: ServerT API AppM
-handler = loginHandler :<|> registerHandler
+handler = loginHandler :<|> registerHandler :<|> newTokenHandler
+
+newTokenHandler :: AuthResult SafeUser -> AppM Token
+newTokenHandler = requireLoggedIn $ \SafeUser{username} ->
+  runDB (createToken username)
 
 loginHandler :: AuthResult SafeUser -> AppM LoginStatus
 loginHandler (Authenticated u) = return (LoginStatus (Just u))

src/Database/Schema.hs

@@ -3,6 +3,7 @@
 {-# Language OverloadedStrings #-}
 {-# Language DuplicateRecordFields #-}
 {-# Language GeneralizedNewtypeDeriving #-}
+{-# Language MultiParamTypeClasses #-}
 module Database.Schema where
 
 import ClassyPrelude
@@ -13,6 +14,11 @@ import Database.Selda.Backend
 import Data.Aeson
 import Web.HttpApiData
 
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import Servant (MimeRender(..), PlainText)
+
 -- | User type
 newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq)
 newtype HashedPassword = HashedPassword {unHashed :: ByteString}
@@ -70,11 +76,24 @@ instance SqlType TagID where
   fromSql _ = error "fromSql: Bad tagid"
   defaultValue = mkLit (TagID (-1))
 
+newtype Token = Token { unToken :: UUID } deriving (Show, ToJSON)
+
+instance MimeRender PlainText Token where
+  mimeRender _ = UUID.toLazyASCIIBytes . unToken
+
+instance SqlType Token where
+  mkLit = LCustom . LText . UUID.toText . unToken
+  fromSql (SqlString x) = maybe (error "fromSql: Could not parse token") Token . UUID.fromText $ x
+  fromSql _ = error "fromSql: Could not parse token"
+  defaultValue = mkLit (Token UUID.nil)
+
 data User pass = User { identifier :: UserID
                       , email :: Email
                       , username :: Username
                       , role :: Role
-                      , password :: pass }
+                      , token :: Maybe Token
+                      , password :: pass
+                      }
           deriving (Show, Generic)
 
 data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic)

src/Database/User.hs

@@ -2,7 +2,15 @@
 {-# Language TypeApplications #-}
 {-# Language DataKinds #-}
 {-# Language TemplateHaskell #-}
-module Database.User where
+{-# Language FlexibleContexts #-}
+module Database.User
+  ( Token
+  , insertUser
+  , getUser
+  , validateUser
+  , createToken
+  , invalidateToken )
+  where
 
 import ClassyPrelude
 import Database
@@ -14,10 +22,12 @@ import Crypto.KDF.BCrypt
 import Crypto.Random.Types (MonadRandom)
 import Control.Monad.Logger
 import Control.Monad (mfilter)
+import qualified Data.UUID.V4 as UUID
 
 data UserExistsError = UserExistsError
 
 
+
 insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
 insertUser username email (PlainPassword password) =
   getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
@@ -26,7 +36,7 @@ insertUser username email (PlainPassword password) =
     insertAs role = do
       lift $ $logInfo $ "Inserting new user as " <> pack (show role)
       let bytePass = encodeUtf8 password
-      user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
+      user <- User def email username role Nothing . HashedPassword <$> lift (hashPassword 12 bytePass)
       insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user)
 
 adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
@@ -58,3 +68,21 @@ getUser' name = listToMaybe . fmap fromRel <$> query q
       u@(_ :*: _ :*: username :*: _ ) <- select (gen users)
       restrict (username .== literal name)
       return u
+
+createToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m Token
+createToken username = do
+  token <- Token <$> liftIO UUID.nextRandom
+  void $ update (gen users) predicate (updateToken token)
+  return token
+  where
+    _ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users)
+    predicate user = user ! pUsername .== literal username
+    updateToken token user= user `with` [pToken := literal (Just token)]
+
+invalidateToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m ()
+invalidateToken username = do
+  void $ update (gen users) predicate updateToken
+  where
+    _ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users)
+    predicate user = user ! pUsername .== literal username
+    updateToken user= user `with` [pToken := literal Nothing]

src/Server/Auth.hs

@@ -6,10 +6,12 @@
 {-# Language DuplicateRecordFields #-}
 {-# Language TypeApplications #-}
 {-# Language TemplateHaskell #-}
+{-# Language FlexibleContexts #-}
 module Server.Auth
   ( SafeUser(..)
   , authCheck
   , AuthResult(..)
+  , TokenCheck
   , requireLoggedIn)
   where
 
@@ -56,3 +58,5 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
 requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
 requireLoggedIn f (Authenticated user) = f user
 requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401
+
+data TokenCheck