@@ -43,16 +43,17 @@ import qualified GHC.Generics as GHC
4343import Data.Aeson
4444import qualified Data.Aeson as A
4545import Data.Binary.Builder (toLazyByteString)
46−import Servant.Docs (ToSample, samples, toSamples, singleSample)
46+import Servant.Docs
4747import qualified Data.Text as T
4848import qualified Data.Text.Encoding as T
4949import Text.Regex
50−import qualified Data.ByteString.Base64 as BS
50+import qualified Data.ByteString.Base64.URL as BS
5151import Data.Maybe
5252import Server.Auth.Token
5353import Server.Auth.Mail
5454import Web.UAParser
5555import qualified Data.Text.Lazy as TL
56+import Server.Auth.HTML
5657
5758-- MARK: Documentation
5859
@@ -74,6 +75,23 @@ instance ToSample TokenActivationData where
7475instance ToSample TokenActivationResult where
7576 toSamples _ = samples [TokenActivationResultYou, TokenActivationResultNotYou]
7677
78+instance ToParam (QueryParam' mods "data" String) where
79+ toParam _ =
80+ DocQueryParam "data"
81+ ["AAABBBC="]
82+ "The data recieved from the email."
83+ Normal
84+
85+instance ToParam (QueryParam' mods "id" UserId) where
86+ toParam _ =
87+ DocQueryParam "id"
88+ ["8"]
89+ "The id of the user."
90+ Normal
91+
92+instance ToSample Markup where
93+ toSamples _ = noSamples
94+
7795type LoginDescription = Description "Try to log in with the given email\n\nResponse fields:\n\n- `registered` -- User is registered and the cookie has been set. You now need to get a verification code from the user and pass it to `/verify`.\n- `canRegister` -- the email is valid, but the user needs to register. Prompt him for information and pass it to `/register`.\n- `invalid` -- the email is invalid."
7896
7997type LogoutDescription = Description "Log out with the given cookie"
@@ -84,6 +102,10 @@ type RegisterDescription = Description "Register the user for a new account.\n\n
84102
85103type 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."
86104
105+type ActivateDescription = Description "Activates a token using data from email"
106+
107+type DeactivateDescription = Description "Deactivates a token using data from email"
108+
87109-- MARK: Implementation
88110
89111type AuthenticationHandler =
@@ -102,13 +124,21 @@ type AuthenticationHandler =
102124 PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent) :<|>
103125 "checkCookie" :> CheckCookieDescription :>
104126 Header "cookie" String :> GetNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
105− "activate"
127+ "activate" :> ActivateDescription
106128 :> Header "cookie" String
107129 :> ReqBody '[JSON] TokenActivationData
108130 :> Post '[JSON] TokenActivationResult :<|>
109− "deactivate"
131+ "deactivate" :> DeactivateDescription
110132 :> ReqBody '[JSON] TokenActivationData
111− :> PostNoContent '[JSON] NoContent
133+ :> PostNoContent '[JSON] NoContent :<|>
134+ "activateUser"
135+ :> QueryParam "id" UserId
136+ :> QueryParam "data" String
137+ :> Get '[HTML] Markup :<|>
138+ "deactivateUser"
139+ :> QueryParam "id" UserId
140+ :> QueryParam "data" String
141+ :> Get '[HTML] Markup
112142
113143data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
114144 deriving (Show)
@@ -160,8 +190,35 @@ instance FromJSON BS.ByteString where
160190newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: UserEmail}
161191 deriving (GHC.Generic, ToJSON, FromJSON)
162192
193+activateUser :: Maybe UserId -> Maybe String -> App Markup
194+activateUser Nothing _ = return $ page "The link is invalid."
195+activateUser _ Nothing = return $ page "The link is invalid."
196+activateUser (Just uId) (Just aData') = catchErrorPage $ do
197+ case BS.decode . C.pack $ aData' of
198+ Left _ -> return $ page $ "The link is invalid."
199+ Right aData -> do
200+ tokenData' <- runQerror $ tryActivateToken uId aData
201+ case tokenData' of
202+ Nothing -> return $ page "This activation link has been invalidated."
203+ Just Token{..} -> return $ genActivationPage "in" tokenUserAgent
204+
205+deactivateUser :: Maybe UserId -> Maybe String -> App Markup
206+deactivateUser Nothing _ = return $ page "The link is invalid."
207+deactivateUser _ Nothing = return $ page "The link is invalid."
208+deactivateUser (Just uId) (Just dData') = catchErrorPage $ do
209+ case BS.decode . C.pack $ dData' of
210+ Left _ -> return $ page $ "The link is invalid."
211+ Right dData -> do
212+ ua' <- runQerror $ deactivateToken uId dData
213+ case ua' of
214+ Nothing -> return $ page "This activation link has been invalidated."
215+ Just ua -> return $ genActivationPage "out" ua
216+
217+catchErrorPage :: App Markup -> App Markup
218+catchErrorPage = flip catchError $ \ (_ :: ServantErr) -> return errorPage
219+
163220authenticationAPI :: ServerT AuthenticationHandler App
164−authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie :<|> validateTokenApi :<|> deactivateTokenApi
221+authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie :<|> validateTokenApi :<|> deactivateTokenApi :<|> activateUser :<|> deactivateUser
165222
166223logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
167224logIn (AuthenticationCredits email') ua' = do
@@ -177,7 +234,7 @@ logIn (AuthenticationCredits email') ua' = do
177234 GeneratedToken token value code activation deactivation <- generateToken userId ua
178235 runQerror . createToken $ token
179236 let cookie = generateCookie token value
180− sendTokenVerificationEmail code (TL.fromStrict ua) email
237+ sendTokenVerificationEmail code userId (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) email
181238 return . addHeader cookie $ UserLoginResponse UserIsRegistered
182239
183240generateCookie :: Token -> BS.ByteString -> String
@@ -228,18 +285,18 @@ validateTokenApi cookie' (TokenActivationData uId aData) = do
228285 tokenData' <- runQerror $ tryActivateToken uId aData
229286 case tokenData' of
230287 Nothing -> throwError err401
231− Just tokenData -> do
288+ Just Token{..} -> do
232289 case cookie' >>= getCookie of
233290 Nothing -> return TokenActivationResultNotYou
234291 Just (AuthenticationCookieData uId' cData) ->
235− if hash cData == tokenData && uId' == uId
292+ if hash cData == tokenValue && uId' == tokenUserId
236293 then return TokenActivationResultYou
237294 else return TokenActivationResultNotYou
238295
239296deactivateTokenApi :: TokenActivationData -> App NoContent
240297deactivateTokenApi (TokenActivationData uId dData) = do
241298 res <- runQerror $ deactivateToken uId dData
242− if res
299+ if isJust res
243300 then return NoContent
244301 else throwError err401
245302
@@ -261,7 +318,7 @@ register creation' ua' = do
261318 let gToken = genToken uId ua
262319 createToken . generatedToken $ gToken
263320 return gToken
264− sendTokenVerificationEmail code (TL.fromStrict ua) (userCreationUserEmail creation)
321+ sendTokenVerificationEmail code (tokenUserId token) (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) (userCreationUserEmail creation)
265322 let cookie = generateCookie token value
266323 return $ addHeader cookie NoContent
267324