@@ -14,9 +14,10 @@ module Server.Auth (
1414 cookieTokenKey,
1515 genAuthServerContext,
1616 AuthenticationHandler,
17− authenticate,
17+ logIn,
1818 contextProxy,
19− AuthenticationCredits(..)
19+ AuthenticationCredits(..),
20+ authenticationAPI
2021) where
2122
2223import Server.App
@@ -35,6 +36,7 @@ import Network.Wai (Request, requestHeaders)
3536import Servant.Server
3637import Web.Cookie
3738import Data.Time.Clock
39+import Data.Time.Calendar
3840import Data.Proxy
3941import qualified GHC.Generics as GHC
4042import Data.Aeson
@@ -48,27 +50,41 @@ instance ToSample AuthenticationCredits where
4850
4951-- MARK: Implementation
5052
51−type AuthenticationHandler = ReqBody '[JSON] AuthenticationCredits :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
53+type AuthenticationHandler =
54+ "login" :>
55+ ReqBody '[JSON] AuthenticationCredits :>
56+ Post '[JSON] (Headers '[Header "Set-Cookie" String] UserId) :<|>
57+ "logout" :>
58+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
5259
53−data AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}
60+newtype AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}
5461 deriving GHC.Generic
5562
5663instance ToJSON AuthenticationCredits
5764instance FromJSON AuthenticationCredits
5865
59−authenticate :: ServerT AuthenticationHandler App
60−authenticate (AuthenticationCredits uId) = do
66+authenticationAPI :: ServerT AuthenticationHandler App
67+authenticationAPI = logIn :<|> logOut
68+
69+logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserId)
70+logIn (AuthenticationCredits uId) = do
6171 expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days
62− tId <- fmap userId . runQ invalidToken . getUser $ uId
72+ tId <- fmap userId . runQ err404 . getUser $ uId
6373 let cookie = defaultSetCookie {
6474 setCookieName = cookieTokenKey,
6575 setCookieValue = C.pack $ show tId,
6676 setCookieExpires = Just expire,
67− -- setCookieDomain = Just "127.0.0.1",
6877 setCookiePath = Just "/" }
69− -- let token = cookieTokenKeyString <> "=" <> show tId <> "; Expires=" <> show expire <> "; Domain=127.0.0.1:2000; Path=/" -- ; Secure" --; HttpOnly"
70− return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent
78+ return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) tId
7179
80+logOut :: App (Headers '[Header "Set-Cookie" String] NoContent)
81+logOut =
82+ let cookie = defaultSetCookie {
83+ setCookieName = cookieTokenKey,
84+ setCookieValue = "invalid",
85+ setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),
86+ setCookiePath = Just "/" }
87+ in return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent
7288
7389checkToken :: DBConnection -> BS.ByteString -> Handler UserId
7490checkToken conn token = do
@@ -80,11 +96,11 @@ checkToken conn token = do
8096authHandler :: DBConnection -> AuthHandler Request UserId
8197authHandler conn = mkAuthHandler handler
8298 where
83− maybeToEither e = maybe (Left e) Right
84− throw401 msg = throwError $ err401 { errBody = msg }
85− handler req = either throw401 (checkToken conn) $ do
86− cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req
87− maybeToEither "Missing token in cookie" $ lookup cookieTokenKey $ parseCookies cookie
99+ maybeToEither = maybe (Left ()) Right
100+ throw = const $ throwError invalidToken
101+ handler req = either throw (checkToken conn) $ do
102+ cookie <- maybeToEither $ lookup "cookie" $ requestHeaders req
103+ maybeToEither $ lookup cookieTokenKey $ parseCookies cookie
88104
89105cookieTokenKey :: BS.ByteString
90106cookieTokenKey = "servant-auth-cookie"