@@ -77,6 +77,8 @@ type VerifyDescription = Description "Verify token with the verification code fr
78type RegisterDescription = Description "Register the user for a new account.\n\nReturns 409 if a user can not be created. (Most likely the email is already registered).\n\nSets the token if creation was successful.\n\nYou should prompt user for code and verify the token with `/verify`."
78type RegisterDescription = Description "Register the user for a new account.\n\nReturns 409 if a user can not be created. (Most likely the email is already registered).\n\nSets the token if creation was successful.\n\nYou should prompt user for code and verify the token with `/verify`."
80+type CheckCookieDescription = Description "Checks if a parseable cookie is present in the request.\n\nDoes not check if the cookie itself contains valid credentials.\n\nReturns 204 NoContent if cookie is present.\n\nReturns 401 Unauthorized if the cookie is not present."
80-- MARK: Implementation
82-- MARK: Implementation
82type AuthenticationHandler =
84type AuthenticationHandler =
@@ -92,7 +94,9 @@ type AuthenticationHandler =
92 "register" :> RegisterDescription :>
94 "register" :> RegisterDescription :>
93 ReqBody '[JSON] UserCreation :>
95 ReqBody '[JSON] UserCreation :>
94 Header "User-Agent" String :>
96 Header "User-Agent" String :>
95− PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
97+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent) :<|>
98+ "checkCookie" :> CheckCookieDescription :>
99+ Header "cookie" String :> GetNoContent '[JSON, PlainText, FormUrlEncoded] NoContent
97data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
101data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
98 deriving (Show)
102 deriving (Show)
@@ -124,7 +128,7 @@ newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: Us
124 deriving (GHC.Generic, ToJSON, FromJSON)
128 deriving (GHC.Generic, ToJSON, FromJSON)
126authenticationAPI :: ServerT AuthenticationHandler App
130authenticationAPI :: ServerT AuthenticationHandler App
127−authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register
131+authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie
129logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
133logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
130logIn (AuthenticationCredits email') ua' = do
134logIn (AuthenticationCredits email') ua' = do
@@ -157,11 +161,20 @@ generateCookie token = L.unpack . toLazyByteString . renderSetCookie $ defaultSe
157 setCookieHttpOnly = True,
161 setCookieHttpOnly = True,
158 setCookieSecure = True }
162 setCookieSecure = True }
164+getCookie :: String -> Maybe AuthenticationCookieData
165+getCookie = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack
167+checkCookie :: Maybe String -> App NoContent
168+checkCookie cookie = do
169+ let token = cookie >>= getCookie
171+ Nothing -> throwError err401
172+ Just _ -> return NoContent
161verifyToken :: Maybe String -> Int32 -> App NoContent
174verifyToken :: Maybe String -> Int32 -> App NoContent
162verifyToken Nothing _ = throwError err400
175verifyToken Nothing _ = throwError err400
163verifyToken (Just cookie) code = do
176verifyToken (Just cookie) code = do
164− let mbToken = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack $ cookie
177+ let mbToken = getCookie cookie
165 case mbToken of
178 case mbToken of
166 Nothing -> throwError err400
179 Nothing -> throwError err400
167 (Just (AuthenticationCookieData uId tokenData)) -> do
180 (Just (AuthenticationCookieData uId tokenData)) -> do
@@ -171,10 +184,9 @@ verifyToken (Just cookie) code = do
171 Nothing -> throwError err403
184 Nothing -> throwError err403
173logOut :: Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)
186logOut :: Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)
174−logOut cookie' = do
187+logOut cookie = do
175 _ <- fromMaybe (return ()) $ do
188 _ <- fromMaybe (return ()) $ do
177− AuthenticationCookieData uId tokenData <- (lookup cookieTokenKey . parseCookies . C.pack $ cookie) >>= (decode . L.fromStrict)
189+ AuthenticationCookieData uId tokenData <- cookie >>= getCookie
178 return . runQsilent $ invalidateToken uId tokenData
190 return . runQsilent $ invalidateToken uId tokenData
179 let newCookie = defaultSetCookie {
191 let newCookie = defaultSetCookie {
180 setCookieName = cookieTokenKey,
192 setCookieName = cookieTokenKey,