@@ -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"
@@ -112,7 +130,15 @@ type AuthenticationHandler =
112130 :> Post '[JSON] TokenActivationResult :<|>
113131 "deactivate" :> DeactivateDescription
114132 :> ReqBody '[JSON] TokenActivationData
115− :> 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
116142
117143data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
118144 deriving (Show)
@@ -164,8 +190,35 @@ instance FromJSON BS.ByteString where
164190newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: UserEmail}
165191 deriving (GHC.Generic, ToJSON, FromJSON)
166192
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+
167220authenticationAPI :: ServerT AuthenticationHandler App
168−authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie :<|> validateTokenApi :<|> deactivateTokenApi
221+authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie :<|> validateTokenApi :<|> deactivateTokenApi :<|> activateUser :<|> deactivateUser
169222
170223logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
171224logIn (AuthenticationCredits email') ua' = do
@@ -181,7 +234,7 @@ logIn (AuthenticationCredits email') ua' = do
181234 GeneratedToken token value code activation deactivation <- generateToken userId ua
182235 runQerror . createToken $ token
183236 let cookie = generateCookie token value
184− sendTokenVerificationEmail code (TL.fromStrict ua) email
237+ sendTokenVerificationEmail code userId (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) email
185238 return . addHeader cookie $ UserLoginResponse UserIsRegistered
186239
187240generateCookie :: Token -> BS.ByteString -> String
@@ -232,18 +285,18 @@ validateTokenApi cookie' (TokenActivationData uId aData) = do
232285 tokenData' <- runQerror $ tryActivateToken uId aData
233286 case tokenData' of
234287 Nothing -> throwError err401
235− Just tokenData -> do
288+ Just Token{..} -> do
236289 case cookie' >>= getCookie of
237290 Nothing -> return TokenActivationResultNotYou
238291 Just (AuthenticationCookieData uId' cData) ->
239− if hash cData == tokenData && uId' == uId
292+ if hash cData == tokenValue && uId' == tokenUserId
240293 then return TokenActivationResultYou
241294 else return TokenActivationResultNotYou
242295
243296deactivateTokenApi :: TokenActivationData -> App NoContent
244297deactivateTokenApi (TokenActivationData uId dData) = do
245298 res <- runQerror $ deactivateToken uId dData
246− if res
299+ if isJust res
247300 then return NoContent
248301 else throwError err401
249302
@@ -265,7 +318,7 @@ register creation' ua' = do
265318 let gToken = genToken uId ua
266319 createToken . generatedToken $ gToken
267320 return gToken
268− sendTokenVerificationEmail code (TL.fromStrict ua) (userCreationUserEmail creation)
321+ sendTokenVerificationEmail code (tokenUserId token) (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) (userCreationUserEmail creation)
269322 let cookie = generateCookie token value
270323 return $ addHeader cookie NoContent
271324