@@ -77,6 +77,8 @@ type VerifyDescription = Description "Verify token with the verification code fr
7777
7878type 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`."
7979
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."
81+
8082-- MARK: Implementation
8183
8284type AuthenticationHandler =
@@ -92,7 +94,9 @@ type AuthenticationHandler =
9294 "register" :> RegisterDescription :>
9395 ReqBody '[JSON] UserCreation :>
9496 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
96100
97101data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
98102 deriving (Show)
@@ -124,7 +128,7 @@ newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: Us
124128 deriving (GHC.Generic, ToJSON, FromJSON)
125129
126130authenticationAPI :: ServerT AuthenticationHandler App
127−authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register
131+authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie
128132
129133logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
130134logIn (AuthenticationCredits email') ua' = do
@@ -157,11 +161,20 @@ generateCookie token = L.unpack . toLazyByteString . renderSetCookie $ defaultSe
157161 setCookieHttpOnly = True,
158162 setCookieSecure = True }
159163
164+getCookie :: String -> Maybe AuthenticationCookieData
165+getCookie = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack
166+
167+checkCookie :: Maybe String -> App NoContent
168+checkCookie cookie = do
169+ let token = cookie >>= getCookie
170+ case token of
171+ Nothing -> throwError err401
172+ Just _ -> return NoContent
160173
161174verifyToken :: Maybe String -> Int32 -> App NoContent
162175verifyToken Nothing _ = throwError err400
163176verifyToken (Just cookie) code = do
164− let mbToken = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack $ cookie
177+ let mbToken = getCookie cookie
165178 case mbToken of
166179 Nothing -> throwError err400
167180 (Just (AuthenticationCookieData uId tokenData)) -> do
@@ -171,10 +184,9 @@ verifyToken (Just cookie) code = do
171184 Nothing -> throwError err403
172185
173186logOut :: Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)
174−logOut cookie' = do
187+logOut cookie = do
175188 _ <- fromMaybe (return ()) $ do
176− cookie <- cookie'
177− AuthenticationCookieData uId tokenData <- (lookup cookieTokenKey . parseCookies . C.pack $ cookie) >>= (decode . L.fromStrict)
189+ AuthenticationCookieData uId tokenData <- cookie >>= getCookie
178190 return . runQsilent $ invalidateToken uId tokenData
179191 let newCookie = defaultSetCookie {
180192 setCookieName = cookieTokenKey,