{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
                   Henry Laxen <nadine.and.henry@pobox.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- Handlers for registering and authenticating users.
-}

module Network.Gitit.Authentication ( loginUserForm
                                    , formAuthHandlers
                                    , httpAuthHandlers
                                    , rpxAuthHandlers
                                    , githubAuthHandlers) where

import Network.Gitit.State
import Network.Gitit.Types
import Network.Gitit.Framework
import Network.Gitit.Layout
import Network.Gitit.Server
import Network.Gitit.Util
import Network.Gitit.Authentication.Github
import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import qualified Text.XHtml as X ( password )
import System.Process (readProcessWithExitCode)
import Control.Monad (unless, liftM, mplus)
import Control.Monad.Trans (liftIO)
import System.Exit
import System.Log.Logger (logM, Priority(..))
import Data.Char (isAlphaNum, isAlpha)
import qualified Data.Map as M
import Data.List (stripPrefix)
import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
import Network.URL (exportURL, add_param, importURL)
import Network.BSD (getHostName)
import qualified Text.StringTemplate as T
import Network.HTTP (urlEncodeVars, urlDecode, urlEncode)
import Codec.Binary.UTF8.String (encodeString)
import Data.ByteString.UTF8 (toString)
import Network.Gitit.Rpxnow as R

-- | Replace each occurrence of one sublist in a list with another.
--   Vendored in from pandoc 2.11.4 as 2.12 removed this function.
substitute :: (Eq a) => [a] -> [a] -> [a] -> [a]
substitute :: [a] -> [a] -> [a] -> [a]
substitute [a]
_ [a]
_ [] = []
substitute [] [a]
_ [a]
xs = [a]
xs
substitute [a]
target' [a]
replacement lst :: [a]
lst@(a
x:[a]
xs) =
    case [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
target' [a]
lst of
      Just [a]
lst' -> [a]
replacement [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
substitute [a]
target' [a]
replacement [a]
lst'
      Maybe [a]
Nothing   -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
substitute [a]
target' [a]
replacement [a]
xs

data ValidationType = Register
                    | ResetPassword
                    deriving (Int -> ValidationType -> ShowS
[ValidationType] -> ShowS
ValidationType -> String
(Int -> ValidationType -> ShowS)
-> (ValidationType -> String)
-> ([ValidationType] -> ShowS)
-> Show ValidationType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationType] -> ShowS
$cshowList :: [ValidationType] -> ShowS
show :: ValidationType -> String
$cshow :: ValidationType -> String
showsPrec :: Int -> ValidationType -> ShowS
$cshowsPrec :: Int -> ValidationType -> ShowS
Show,ReadPrec [ValidationType]
ReadPrec ValidationType
Int -> ReadS ValidationType
ReadS [ValidationType]
(Int -> ReadS ValidationType)
-> ReadS [ValidationType]
-> ReadPrec ValidationType
-> ReadPrec [ValidationType]
-> Read ValidationType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ValidationType]
$creadListPrec :: ReadPrec [ValidationType]
readPrec :: ReadPrec ValidationType
$creadPrec :: ReadPrec ValidationType
readList :: ReadS [ValidationType]
$creadList :: ReadS [ValidationType]
readsPrec :: Int -> ReadS ValidationType
$creadsPrec :: Int -> ReadS ValidationType
Read)

registerUser :: Params -> Handler
registerUser :: Params -> Handler
registerUser Params
params = do
  Either [String] (String, String, String)
result' <- ValidationType
-> Params
-> GititServerPart (Either [String] (String, String, String))
sharedValidation ValidationType
Register Params
params
  case Either [String] (String, String, String)
result' of
    Left [String]
errors -> GititServerPart Html
registerForm GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                          pgMessages :: [String]
pgMessages = [String]
errors,
                          pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                          pgTabs :: [Tab]
pgTabs = [],
                          pgTitle :: String
pgTitle = String
"Register for an account"
                          }
    Right (String
uname, String
email, String
pword) -> do
       User
user <- IO User -> ServerPartT (ReaderT WikiState IO) User
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ServerPartT (ReaderT WikiState IO) User)
-> IO User -> ServerPartT (ReaderT WikiState IO) User
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO User
mkUser String
uname String
email String
pword
       String -> User -> GititServerPart ()
addUser String
uname User
user
       Params -> Handler
loginUser Params
params{ pUsername :: String
pUsername = String
uname,
                         pPassword :: String
pPassword = String
pword,
                         pEmail :: String
pEmail = String
email }

resetPasswordRequestForm :: Params -> Handler
resetPasswordRequestForm :: Params -> Handler
resetPasswordRequestForm Params
_ = do
  let passwordForm :: Html
passwordForm = String -> Html -> Html
gui String
"" (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"resetPassword"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
fieldset (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
              [ Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Username: "
              , String -> Html
textfield String
"username" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
1], String -> Html
stringToHtml String
" "
              , String -> String -> Html
submit String
"resetPassword" String
"Reset Password" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
2]]
  Config
cfg <- GititServerPart Config
getConfig
  let contents :: Html
contents = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
mailCommand Config
cfg)
                    then Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Sorry, password reset not available."
                    else Html
passwordForm
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgTabs :: [Tab]
pgTabs = [],
                  pgTitle :: String
pgTitle = String
"Reset your password" }
                Html
contents

resetPasswordRequest :: Params -> Handler
resetPasswordRequest :: Params -> Handler
resetPasswordRequest Params
params = do
  let uname :: String
uname = Params -> String
pUsername Params
params
  Maybe User
mbUser <- String -> GititServerPart (Maybe User)
getUser String
uname
  let errors :: [String]
errors = case Maybe User
mbUser of
        Maybe User
Nothing -> [String
"Unknown user. Please re-register " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
"or press the Back button to try again."]
        Just User
u  -> [String
"Since you did not register with " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                   String
"an email address, we can't reset your password." |
                    String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (User -> String
uEmail User
u) ]
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
    then do
      let response :: Html
response =
            Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"An email has been sent to "
                 , Html -> Html
bold (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
stringToHtml (String -> Html) -> (User -> String) -> User -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> String
uEmail (User -> Html) -> User -> Html
forall a b. (a -> b) -> a -> b
$ Maybe User -> User
forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
mbUser
                 , Html
br
                 , String -> Html
stringToHtml
                   String
"Please click on the enclosed link to reset your password."
                 ]
      User -> GititServerPart ()
sendReregisterEmail (Maybe User -> User
forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
mbUser)
      PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                      pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                      pgTabs :: [Tab]
pgTabs = [],
                      pgTitle :: String
pgTitle = String
"Resetting your password"
                      }
                    Html
response
    else GititServerPart Html
registerForm GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
         PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                         pgMessages :: [String]
pgMessages = [String]
errors,
                         pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                         pgTabs :: [Tab]
pgTabs = [],
                         pgTitle :: String
pgTitle = String
"Register for an account"
                         }

resetLink :: String -> User -> String
resetLink :: String -> User -> String
resetLink String
base' User
user =
  URL -> String
exportURL (URL -> String) -> URL -> String
forall a b. (a -> b) -> a -> b
$  (URL -> (String, String) -> URL)
-> URL -> [(String, String)] -> URL
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl URL -> (String, String) -> URL
add_param
    (Maybe URL -> URL
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URL -> URL) -> (String -> Maybe URL) -> String -> URL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe URL
importURL (String -> URL) -> String -> URL
forall a b. (a -> b) -> a -> b
$ String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_doResetPassword")
    [(String
"username", User -> String
uUsername User
user), (String
"reset_code", Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
20 (Password -> String
pHashed (User -> Password
uPassword User
user)))]

sendReregisterEmail :: User -> GititServerPart ()
sendReregisterEmail :: User -> GititServerPart ()
sendReregisterEmail User
user = do
  Config
cfg <- GititServerPart Config
getConfig
  String
hostname <- IO String -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getHostName
  String
base' <- ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let messageTemplate :: StringTemplate String
messageTemplate = String -> StringTemplate String
forall a. Stringable a => String -> StringTemplate a
T.newSTMP (String -> StringTemplate String)
-> String -> StringTemplate String
forall a b. (a -> b) -> a -> b
$ Config -> String
resetPasswordMessage Config
cfg
  let filledTemplate :: String
filledTemplate = StringTemplate String -> String
forall a. Stringable a => StringTemplate a -> a
T.render (StringTemplate String -> String)
-> (StringTemplate String -> StringTemplate String)
-> StringTemplate String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> String -> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"username" (User -> String
uUsername User
user) (StringTemplate String -> StringTemplate String)
-> (StringTemplate String -> StringTemplate String)
-> StringTemplate String
-> StringTemplate String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> String -> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"useremail" (User -> String
uEmail User
user) (StringTemplate String -> StringTemplate String)
-> (StringTemplate String -> StringTemplate String)
-> StringTemplate String
-> StringTemplate String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> String -> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"hostname" String
hostname (StringTemplate String -> StringTemplate String)
-> (StringTemplate String -> StringTemplate String)
-> StringTemplate String
-> StringTemplate String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> String -> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"port" (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Config -> Int
portNumber Config
cfg) (StringTemplate String -> StringTemplate String)
-> (StringTemplate String -> StringTemplate String)
-> StringTemplate String
-> StringTemplate String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> String -> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"resetlink" (String -> User -> String
resetLink String
base' User
user) (StringTemplate String -> String)
-> StringTemplate String -> String
forall a b. (a -> b) -> a -> b
$
                       StringTemplate String
messageTemplate
  let (String
mailcommand:[String]
args) = String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> ShowS
forall a. Eq a => [a] -> [a] -> [a] -> [a]
substitute String
"%s" (User -> String
uEmail User
user)
                                   (Config -> String
mailCommand Config
cfg)
  (ExitCode
exitCode, String
_pOut, String
pErr) <- IO (ExitCode, String, String)
-> ServerPartT (ReaderT WikiState IO) (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String)
 -> ServerPartT (ReaderT WikiState IO) (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ServerPartT (ReaderT WikiState IO) (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
mailcommand [String]
args
                                      String
filledTemplate
  IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent reset password email to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ User -> String
uUsername User
user String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ User -> String
uEmail User
user
  Bool -> GititServerPart () -> GititServerPart ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (GititServerPart () -> GititServerPart ())
-> GititServerPart () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$
    IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
mailcommand String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pErr

validateReset :: Params -> (User -> Handler) -> Handler
validateReset :: Params -> (User -> Handler) -> Handler
validateReset Params
params User -> Handler
postValidate = do
  let uname :: String
uname = Params -> String
pUsername Params
params
  Maybe User
user <- String -> GititServerPart (Maybe User)
getUser String
uname
  let knownUser :: Bool
knownUser = Maybe User -> Bool
forall a. Maybe a -> Bool
isJust Maybe User
user
  let resetCodeMatches :: Bool
resetCodeMatches = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
20 (Password -> String
pHashed (User -> Password
uPassword (Maybe User -> User
forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
user))) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==
                           Params -> String
pResetCode Params
params
  let errors :: [String]
errors = case (Bool
knownUser, Bool
resetCodeMatches) of
                     (Bool
True, Bool
True)   -> []
                     (Bool
True, Bool
False)  -> [String
"Your reset code is invalid"]
                     (Bool
False, Bool
_)     -> [String
"User " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       Html -> String
forall html. HTML html => html -> String
renderHtmlFragment (String -> Html
stringToHtml String
uname) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" is not known"]
  if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
     then User -> Handler
postValidate (Maybe User -> User
forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
user)
     else GititServerPart Html
registerForm GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                          pgMessages :: [String]
pgMessages = [String]
errors,
                          pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                          pgTabs :: [Tab]
pgTabs = [],
                          pgTitle :: String
pgTitle = String
"Register for an account"
                          }

resetPassword :: Params -> Handler
resetPassword :: Params -> Handler
resetPassword Params
params = Params -> (User -> Handler) -> Handler
validateReset Params
params ((User -> Handler) -> Handler) -> (User -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \User
user ->
  Maybe User -> GititServerPart Html
resetPasswordForm (User -> Maybe User
forall a. a -> Maybe a
Just User
user) GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                  pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                  pgTabs :: [Tab]
pgTabs = [],
                  pgTitle :: String
pgTitle = String
"Reset your registration info"
                  }

doResetPassword :: Params -> Handler
doResetPassword :: Params -> Handler
doResetPassword Params
params = Params -> (User -> Handler) -> Handler
validateReset Params
params ((User -> Handler) -> Handler) -> (User -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \User
user -> do
  Either [String] (String, String, String)
result' <- ValidationType
-> Params
-> GititServerPart (Either [String] (String, String, String))
sharedValidation ValidationType
ResetPassword Params
params
  case Either [String] (String, String, String)
result' of
    Left [String]
errors ->
      Maybe User -> GititServerPart Html
resetPasswordForm (User -> Maybe User
forall a. a -> Maybe a
Just User
user) GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                          pgMessages :: [String]
pgMessages = [String]
errors,
                          pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                          pgTabs :: [Tab]
pgTabs = [],
                          pgTitle :: String
pgTitle = String
"Reset your registration info"
                          }
    Right (String
uname, String
email, String
pword) -> do
       User
user' <- IO User -> ServerPartT (ReaderT WikiState IO) User
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ServerPartT (ReaderT WikiState IO) User)
-> IO User -> ServerPartT (ReaderT WikiState IO) User
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO User
mkUser String
uname String
email String
pword
       String -> User -> GititServerPart ()
adjustUser String
uname User
user'
       IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Successfully reset password and email for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ User -> String
uUsername User
user'
       Params -> Handler
loginUser Params
params{ pUsername :: String
pUsername = String
uname,
                         pPassword :: String
pPassword = String
pword,
                         pEmail :: String
pEmail = String
email }

registerForm :: GititServerPart Html
registerForm :: GititServerPart Html
registerForm = Maybe User -> GititServerPart Html
sharedForm Maybe User
forall a. Maybe a
Nothing

resetPasswordForm :: Maybe User -> GititServerPart Html
resetPasswordForm :: Maybe User -> GititServerPart Html
resetPasswordForm = Maybe User -> GititServerPart Html
sharedForm  -- synonym for now

sharedForm :: Maybe User -> GititServerPart Html
sharedForm :: Maybe User -> GititServerPart Html
sharedForm Maybe User
mbUser = (Params -> GititServerPart Html) -> GititServerPart Html
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> GititServerPart Html) -> GititServerPart Html)
-> (Params -> GititServerPart Html) -> GititServerPart Html
forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  Config
cfg <- GititServerPart Config
getConfig
  String
dest <- case Params -> String
pDestination Params
params of
                String
""  -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getReferer
                String
x   -> String -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
  let accessQ :: Html
accessQ = case Maybe User
mbUser of
            Just User
_ -> Html
noHtml
            Maybe User
Nothing -> case Config -> Maybe (String, [String])
accessQuestion Config
cfg of
                      Maybe (String, [String])
Nothing          -> Html
noHtml
                      Just (String
prompt, [String]
_) -> Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"accessCode"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
prompt Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                                          String -> Html
X.password String
"accessCode" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"15", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
1]
                                          Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br
  let captcha :: Html
captcha = if Config -> Bool
useRecaptcha Config
cfg
                   then String -> Maybe String -> Html
captchaFields (Config -> String
recaptchaPublicKey Config
cfg) Maybe String
forall a. Maybe a
Nothing
                   else Html
noHtml
  let initField :: (User -> String) -> String
initField User -> String
field = case Maybe User
mbUser of
                      Maybe User
Nothing    -> String
""
                      Just User
user  -> User -> String
field User
user
  let userNameField :: Html
userNameField = case Maybe User
mbUser of
                      Maybe User
Nothing    -> Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                                     String
"Username (at least 3 letters or digits):"
                                    Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                                    String -> Html
textfield String
"username" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
2] Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br
                      Just User
user  -> Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                                    (String
"Username (cannot be changed): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ User -> String
uUsername User
user)
                                    Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br
  let submitField :: Html
submitField = case Maybe User
mbUser of
                      Maybe User
Nothing    -> String -> String -> Html
submit String
"register" String
"Register"
                      Just User
_     -> String -> String -> Html
submit String
"resetPassword" String
"Reset Password"

  Html -> GititServerPart Html
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> GititServerPart Html) -> Html -> GititServerPart Html
forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
gui String
"" (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"loginForm"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
fieldset (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
            [ Html
accessQ
            , Html
userNameField
            , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"email"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Email (optional, will not be displayed on the Wiki):"
            , Html
br
            , String -> Html
textfield String
"email" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
3, String -> HtmlAttr
value ((User -> String) -> String
initField User -> String
uEmail)]
            , Html
br Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"req"]
            , String -> Html
textfield String
"full_name_1" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> HtmlAttr
theclass String
"req"]
            , Html
br
            , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password"]
                    (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Password (at least 6 characters," String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        String
" including at least one non-letter):")
            , Html
br
            , String -> Html
X.password String
"password" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
4]
            , String -> Html
stringToHtml String
" "
            , Html
br
            , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password2"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Confirm Password:"
            , Html
br
            , String -> Html
X.password String
"password2" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
5]
            , String -> Html
stringToHtml String
" "
            , Html
br
            , Html
captcha
            , String -> Html
textfield String
"destination" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle String
"display: none;", String -> HtmlAttr
value String
dest]
            , Html
submitField Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
6]]


sharedValidation :: ValidationType
                 -> Params
                 -> GititServerPart (Either [String] (String,String,String))
sharedValidation :: ValidationType
-> Params
-> GititServerPart (Either [String] (String, String, String))
sharedValidation ValidationType
validationType Params
params = do
  let isValidUsernameChar :: Char -> Bool
isValidUsernameChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
  let isValidUsername :: t Char -> Bool
isValidUsername t Char
u = t Char -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& (Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isValidUsernameChar t Char
u
  let isValidPassword :: t Char -> Bool
isValidPassword t Char
pw = t Char -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
pw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlpha t Char
pw)
  let accessCode :: String
accessCode = Params -> String
pAccessCode Params
params
  let uname :: String
uname = Params -> String
pUsername Params
params
  let pword :: String
pword = Params -> String
pPassword Params
params
  let pword2 :: String
pword2 = Params -> String
pPassword2 Params
params
  let email :: String
email = Params -> String
pEmail Params
params
  let fakeField :: String
fakeField = Params -> String
pFullName Params
params
  let recaptcha :: Recaptcha
recaptcha = Params -> Recaptcha
pRecaptcha Params
params
  Bool
taken <- String -> GititServerPart Bool
isUser String
uname
  Config
cfg <- GititServerPart Config
getConfig
  let optionalTests :: ValidationType -> [(Bool, String)]
optionalTests ValidationType
Register =
          [(Bool
taken, String
"Sorry, that username is already taken.")]
      optionalTests ValidationType
ResetPassword = []
  let isValidAccessCode :: Bool
isValidAccessCode = case ValidationType
validationType of
        ValidationType
ResetPassword -> Bool
True
        ValidationType
Register -> case Config -> Maybe (String, [String])
accessQuestion Config
cfg of
            Maybe (String, [String])
Nothing           -> Bool
True
            Just (String
_, [String]
answers) -> String
accessCode String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
answers
  let isValidEmail :: String -> Bool
isValidEmail String
e = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'@') String
e) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  String
peer <- (Request -> String)
-> ServerPartT (ReaderT WikiState IO) Request
-> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((String, Int) -> String
forall a b. (a, b) -> a
fst ((String, Int) -> String)
-> (Request -> (String, Int)) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> (String, Int)
rqPeer) ServerPartT (ReaderT WikiState IO) Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  Either String ()
captchaResult <-
    if Config -> Bool
useRecaptcha Config
cfg
       then if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Recaptcha -> String
recaptchaChallengeField Recaptcha
recaptcha) Bool -> Bool -> Bool
||
                 String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Recaptcha -> String
recaptchaResponseField Recaptcha
recaptcha)
               -- no need to bother captcha.net in this case
               then Either String ()
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ()
 -> ServerPartT (ReaderT WikiState IO) (Either String ()))
-> Either String ()
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"missing-challenge-or-response"
               else IO (Either String ())
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ())
 -> ServerPartT (ReaderT WikiState IO) (Either String ()))
-> IO (Either String ())
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall a b. (a -> b) -> a -> b
$ do
                      Maybe String
mbIPaddr <- String -> IO (Maybe String)
lookupIPAddr String
peer
                      let ipaddr :: String
ipaddr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Could not find ip address for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
peer)
                                   Maybe String
mbIPaddr
                      String
ipaddr String -> IO (Either String ()) -> IO (Either String ())
`seq` String -> String -> String -> String -> IO (Either String ())
validateCaptcha (Config -> String
recaptchaPrivateKey Config
cfg)
                              String
ipaddr (Recaptcha -> String
recaptchaChallengeField Recaptcha
recaptcha)
                              (Recaptcha -> String
recaptchaResponseField Recaptcha
recaptcha)
       else Either String ()
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ()
 -> ServerPartT (ReaderT WikiState IO) (Either String ()))
-> Either String ()
-> ServerPartT (ReaderT WikiState IO) (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
  let (Bool
validCaptcha, Maybe String
captchaError) =
        case Either String ()
captchaResult of
              Right () -> (Bool
True, Maybe String
forall a. Maybe a
Nothing)
              Left String
err -> (Bool
False, String -> Maybe String
forall a. a -> Maybe a
Just String
err)
  let errors :: [String]
errors = [(Bool, String)] -> [String]
validate ([(Bool, String)] -> [String]) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ValidationType -> [(Bool, String)]
optionalTests ValidationType
validationType [(Bool, String)] -> [(Bool, String)] -> [(Bool, String)]
forall a. [a] -> [a] -> [a]
++
        [ (Bool -> Bool
not Bool
isValidAccessCode, String
"Incorrect response to access prompt.")
        , (Bool -> Bool
not (String -> Bool
forall (t :: * -> *). Foldable t => t Char -> Bool
isValidUsername String
uname),
         String
"Username must be at least 3 characters, all letters or digits.")
        , (Bool -> Bool
not (String -> Bool
forall (t :: * -> *). Foldable t => t Char -> Bool
isValidPassword String
pword),
         String
"Password must be at least 6 characters, " String -> ShowS
forall a. [a] -> [a] -> [a]
++
         String
"and must contain at least one non-letter.")
        , (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
email) Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
isValidEmail String
email),
         String
"Email address appears invalid.")
        , (String
pword String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
pword2,
        String
"Password does not match confirmation.")
        , (Bool -> Bool
not Bool
validCaptcha,
        String
"Failed CAPTCHA (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
captchaError String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"). Are you really human?")
        , (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fakeField), -- fakeField is hidden in CSS (honeypot)
        String
"You do not seem human enough. If you're sure you are human, " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"try turning off form auto-completion in your browser.")
        ]
  Either [String] (String, String, String)
-> GititServerPart (Either [String] (String, String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [String] (String, String, String)
 -> GititServerPart (Either [String] (String, String, String)))
-> Either [String] (String, String, String)
-> GititServerPart (Either [String] (String, String, String))
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors then (String, String, String)
-> Either [String] (String, String, String)
forall a b. b -> Either a b
Right (String
uname, String
email, String
pword) else [String] -> Either [String] (String, String, String)
forall a b. a -> Either a b
Left [String]
errors

-- user authentication
loginForm :: String -> GititServerPart Html
loginForm :: String -> GititServerPart Html
loginForm String
dest = do
  Config
cfg <- GititServerPart Config
getConfig
  String
base' <- ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  Html -> GititServerPart Html
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> GititServerPart Html) -> Html -> GititServerPart Html
forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
gui (String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_login") (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"loginForm"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
    Html -> Html
fieldset (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
      [ Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Username "
      , String -> Html
textfield String
"username" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"15", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
1]
      , String -> Html
stringToHtml String
" "
      , Html -> Html
label (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Password "
      , String -> Html
X.password String
"password" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"15", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
2]
      , String -> Html
stringToHtml String
" "
      , String -> Html
textfield String
"destination" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle String
"display: none;", String -> HtmlAttr
value String
dest]
      , String -> String -> Html
submit String
"login" String
"Login" Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
3]
      ] Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
    (if Config -> Bool
disableRegistration Config
cfg
       then Html
noHtml
       else Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"If you do not have an account, "
                 , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_register?" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                     [(String, String)] -> String
urlEncodeVars [(String
"destination", ShowS
encodeString String
dest)]] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
"click here to get one."
                 ]) Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
    (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
mailCommand Config
cfg)
       then Html
noHtml
       else Html -> Html
p (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"If you forgot your password, "
                 , Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_resetPassword"] (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<
                     String
"click here to get a new one."
                 ])

loginUserForm :: Handler
loginUserForm :: Handler
loginUserForm = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  String
dest <- case Params -> String
pDestination Params
params of
                String
""  -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getReferer
                String
x   -> String -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
  String -> GititServerPart Html
loginForm String
dest GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{ pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                                     pgTabs :: [Tab]
pgTabs = [],
                                     pgTitle :: String
pgTitle = String
"Login",
                                     pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params
                                   }

loginUser :: Params -> Handler
loginUser :: Params -> Handler
loginUser Params
params = do
  let uname :: String
uname = Params -> String
pUsername Params
params
  let pword :: String
pword = Params -> String
pPassword Params
params
  let destination :: String
destination = Params -> String
pDestination Params
params
  Bool
allowed <- String -> String -> GititServerPart Bool
authUser String
uname String
pword
  Config
cfg <- GititServerPart Config
getConfig
  if Bool
allowed
    then do
      SessionKey
key <- SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey
forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
uname)
      CookieLife -> Cookie -> GititServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
      String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> Response) -> Html -> Response
forall a b. (a -> b) -> a -> b
$ Html -> Html
p (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Welcome, " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Html -> String
forall html. HTML html => html -> String
renderHtmlFragment (String -> Html
stringToHtml String
uname))
    else
      [String] -> Handler -> Handler
forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages [String
"Invalid username or password."] Handler
loginUserForm

logoutUser :: Params -> Handler
logoutUser :: Params -> Handler
logoutUser Params
params = do
  let key :: Maybe SessionKey
key = Params -> Maybe SessionKey
pSessionKey Params
params
  String
dest <- case Params -> String
pDestination Params
params of
                String
""  -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getReferer
                String
x   -> String -> ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
  case Maybe SessionKey
key of
       Just SessionKey
k  -> do
         SessionKey -> GititServerPart ()
forall (m :: * -> *). MonadIO m => SessionKey -> m ()
delSession SessionKey
k
         String -> GititServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie String
"sid"
       Maybe SessionKey
Nothing -> () -> GititServerPart ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
dest) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse String
"You have been logged out."

registerUserForm :: Handler
registerUserForm :: Handler
registerUserForm = GititServerPart Html
registerForm GititServerPart Html -> (Html -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    PageLayout -> Html -> Handler
formattedPage PageLayout
defaultPageLayout{
                    pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                    pgTabs :: [Tab]
pgTabs = [],
                    pgTitle :: String
pgTitle = String
"Register for an account"
                    }

regAuthHandlers :: [Handler]
regAuthHandlers :: [Handler]
regAuthHandlers =
  [ String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_register"  (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler
registerUserForm
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_register"  (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
registerUser
  ]

formAuthHandlers :: Bool -> [Handler]
formAuthHandlers :: Bool -> [Handler]
formAuthHandlers Bool
disableReg =
  (if Bool
disableReg
    then []
    else [Handler]
regAuthHandlers) [Handler] -> [Handler] -> [Handler]
forall a. [a] -> [a] -> [a]
++
  [ String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login"     (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET  GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler
loginUserForm
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login"     (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
loginUser
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout"    (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET  GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_resetPassword"   (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET  GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPasswordRequestForm
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_resetPassword"   (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPasswordRequest
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_doResetPassword" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET  GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPassword
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_doResetPassword" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
doResetPassword
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser
  ]

loginUserHTTP :: Params -> Handler
loginUserHTTP :: Params -> Handler
loginUserHTTP Params
params = do
  String
base' <- ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let destination :: String
destination = Params -> String
pDestination Params
params String -> ShowS
forall a. [a] -> [a] -> [a]
`orIfNull` (String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/")
  String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ () -> Response
forall a. ToMessage a => a -> Response
toResponse ()

logoutUserHTTP :: Handler
logoutUserHTTP :: Handler
logoutUserHTTP = Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ () -> Response
forall a. ToMessage a => a -> Response
toResponse ()  -- will this work?

httpAuthHandlers :: [Handler]
httpAuthHandlers :: [Handler]
httpAuthHandlers =
  [ String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" Handler
logoutUserHTTP
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login"  (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
loginUserHTTP
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]

oauthGithubCallback :: GithubConfig
                   -> GithubCallbackPars                  -- ^ Authentication code gained after authorization
                   -> Handler
oauthGithubCallback :: GithubConfig -> GithubCallbackPars -> Handler
oauthGithubCallback GithubConfig
ghConfig GithubCallbackPars
githubCallbackPars =
  (Maybe SessionKey -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Maybe SessionKey -> Handler) -> Handler)
-> (Maybe SessionKey -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \(Maybe SessionKey
sk :: Maybe SessionKey) ->
      do
        Maybe SessionData
mbSd <- ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
-> (SessionKey
    -> ServerPartT (ReaderT WikiState IO) (Maybe SessionData))
-> Maybe SessionKey
-> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe SessionData
-> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing) SessionKey
-> ServerPartT (ReaderT WikiState IO) (Maybe SessionData)
forall (m :: * -> *).
MonadIO m =>
SessionKey -> m (Maybe SessionData)
getSession Maybe SessionKey
sk
        let mbGititState :: Maybe SessionGithubData
mbGititState = Maybe SessionData
mbSd Maybe SessionData
-> (SessionData -> Maybe SessionGithubData)
-> Maybe SessionGithubData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SessionData -> Maybe SessionGithubData
sessionGithubData
            githubData :: SessionGithubData
githubData = SessionGithubData -> Maybe SessionGithubData -> SessionGithubData
forall a. a -> Maybe a -> a
fromMaybe (String -> SessionGithubData
forall a. HasCallStack => String -> a
error String
"No Github state found in session (is it the same domain?)") Maybe SessionGithubData
mbGititState
            gititState :: String
gititState = SessionGithubData -> String
sessionGithubState SessionGithubData
githubData
            destination :: String
destination = SessionGithubData -> String
sessionGithubDestination SessionGithubData
githubData
        Either GithubLoginError User
mUser <- GithubConfig
-> GithubCallbackPars
-> String
-> GititServerPart (Either GithubLoginError User)
getGithubUser GithubConfig
ghConfig GithubCallbackPars
githubCallbackPars String
gititState
        String
base' <- ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        case Either GithubLoginError User
mUser of
          Right User
user -> do
                     let userEmail :: String
userEmail = User -> String
uEmail User
user
                     (GititState -> GititState) -> GititServerPart ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState ((GititState -> GititState) -> GititServerPart ())
-> (GititState -> GititState) -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ \GititState
s -> GititState
s { users :: Map String User
users = String -> User -> Map String User -> Map String User
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
userEmail User
user (GititState -> Map String User
users GititState
s) }
                     String -> User -> GititServerPart ()
addUser (User -> String
uUsername User
user) User
user
                     SessionKey
key <- SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey
forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
userEmail)
                     Config
cfg <- GititServerPart Config
getConfig
                     CookieLife -> Cookie -> GititServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
                     String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ () -> Response
forall a. ToMessage a => a -> Response
toResponse ()
          Left GithubLoginError
err -> do
              IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Login Failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GithubLoginError -> String
ghUserMessage GithubLoginError
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
". Github response" String -> ShowS
forall a. [a] -> [a] -> [a]
++) (GithubLoginError -> Maybe String
ghDetails GithubLoginError
err)
              Config
cfg <- GititServerPart Config
getConfig
              let destination' :: String
destination'
                    | Config -> AuthenticationLevel
requireAuthentication Config
cfg AuthenticationLevel -> AuthenticationLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= AuthenticationLevel
ForRead = String
base' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_loginFailure"
                    | Bool
otherwise                            = String
destination
              let url :: String
url = String
destination' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"?message=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GithubLoginError -> String
ghUserMessage GithubLoginError
err
              String -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
url) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ () -> Response
forall a. ToMessage a => a -> Response
toResponse ()

githubAuthHandlers :: GithubConfig
                   -> [Handler]
githubAuthHandlers :: GithubConfig -> [Handler]
githubAuthHandlers GithubConfig
ghConfig =
  [ String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Params -> Handler
loginGithubUser (OAuth2 -> Params -> Handler) -> OAuth2 -> Params -> Handler
forall a b. (a -> b) -> a -> b
$ GithubConfig -> OAuth2
oAuth2 GithubConfig
ghConfig
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_loginFailure" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Handler
githubLoginFailure
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_githubCallback" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ (GithubCallbackPars -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((GithubCallbackPars -> Handler) -> Handler)
-> (GithubCallbackPars -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ GithubConfig -> GithubCallbackPars -> Handler
oauthGithubCallback GithubConfig
ghConfig
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]

githubLoginFailure :: Handler
githubLoginFailure :: Handler
githubLoginFailure = (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
forall a b. (a -> b) -> a -> b
$ \Params
params ->
  PageLayout -> Html -> Handler
formattedPage ([String] -> PageLayout
pageLayout (Params -> [String]
pMessages Params
params)) Html
noHtml Handler -> (Response -> Handler) -> Handler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
forbidden
  where
    pageLayout :: [String] -> PageLayout
pageLayout [String]
msgs =
      PageLayout
defaultPageLayout{ pgShowPageTools :: Bool
pgShowPageTools = Bool
False,
                         pgTabs :: [Tab]
pgTabs = [],
                         pgTitle :: String
pgTitle = String
"Login failure",
                         pgMessages :: [String]
pgMessages = [String]
msgs
                       }

-- Login using RPX (see RPX development docs at https://rpxnow.com/docs)
loginRPXUser :: RPars  -- ^ The parameters passed by the RPX callback call (after authentication has taken place
             -> Handler
loginRPXUser :: RPars -> Handler
loginRPXUser RPars
params = do
  Config
cfg <- GititServerPart Config
getConfig
  String
ref <- ServerPartT (ReaderT WikiState IO) String
forall (m :: * -> *). ServerMonad m => m String
getReferer
  let mtoken :: Maybe String
mtoken = RPars -> Maybe String
rToken RPars
params
  if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
mtoken
     then do
       let url :: String
url = Config -> String
baseUrl Config
cfg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/_login?destination=" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
ref (RPars -> Maybe String
rDestination RPars
params)
       if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
rpxDomain Config
cfg)
          then String -> Handler
forall a. HasCallStack => String -> a
error String
"rpx-domain is not set."
          else do
             let rpx :: String
rpx = String
"https://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Config -> String
rpxDomain Config
cfg String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
".rpxnow.com/openid/v2/signin?token_url=" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       ShowS
urlEncode String
url
             String -> Handler
forall (m :: * -> *).
FilterMonad Response m =>
String -> m Response
see String
rpx
     else do -- We got an answer from RPX, this might also return an exception.
       Either String Identifier
uid' :: Either String R.Identifier <- IO (Either String Identifier)
-> ServerPartT (ReaderT WikiState IO) (Either String Identifier)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String Identifier)
 -> ServerPartT (ReaderT WikiState IO) (Either String Identifier))
-> IO (Either String Identifier)
-> ServerPartT (ReaderT WikiState IO) (Either String Identifier)
forall a b. (a -> b) -> a -> b
$
                      String -> String -> IO (Either String Identifier)
R.authenticate (Config -> String
rpxKey Config
cfg) (String -> IO (Either String Identifier))
-> String -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
mtoken
       Identifier
uid <- case Either String Identifier
uid' of
                   Right Identifier
u -> Identifier -> ServerPartT (ReaderT WikiState IO) Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
u
                   Left String
err -> String -> ServerPartT (ReaderT WikiState IO) Identifier
forall a. HasCallStack => String -> a
error String
err
       IO () -> GititServerPart ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GititServerPart ()) -> IO () -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit.loginRPXUser" Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"uid:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
uid
       -- We need to get an unique identifier for the user
       -- The 'identifier' is always present but can be rather cryptic
       -- The 'verifiedEmail' is also unique and is a more readable choice
       -- so we use it if present.
       let userId :: String
userId = Identifier -> String
R.userIdentifier Identifier
uid
       let email :: Maybe String
email  = String -> Identifier -> Maybe String
prop String
"verifiedEmail" Identifier
uid
       User
user <- IO User -> ServerPartT (ReaderT WikiState IO) User
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ServerPartT (ReaderT WikiState IO) User)
-> IO User -> ServerPartT (ReaderT WikiState IO) User
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO User
mkUser (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
userId Maybe String
email) (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
email) String
"none"
       (GititState -> GititState) -> GititServerPart ()
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState ((GititState -> GititState) -> GititServerPart ())
-> (GititState -> GititState) -> GititServerPart ()
forall a b. (a -> b) -> a -> b
$ \GititState
s -> GititState
s { users :: Map String User
users = String -> User -> Map String User -> Map String User
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
userId User
user (GititState -> Map String User
users GititState
s) }
       SessionKey
key <- SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey
forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
userId)
       CookieLife -> Cookie -> GititServerPart ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
       String -> Handler
forall (m :: * -> *).
FilterMonad Response m =>
String -> m Response
see (String -> Handler) -> String -> Handler
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ RPars -> Maybe String
rDestination RPars
params
      where
        prop :: String -> Identifier -> Maybe String
prop String
pname Identifier
info = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname ([(String, String)] -> Maybe String)
-> [(String, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Identifier -> [(String, String)]
R.userData Identifier
info
        see :: String -> m Response
see String
url = String -> Response -> m Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
url) (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Html -> Response
forall a. ToMessage a => a -> Response
toResponse Html
noHtml

-- The parameters passed by the RPX callback call.
data RPars = RPars { RPars -> Maybe String
rToken       :: Maybe String
                   , RPars -> Maybe String
rDestination :: Maybe String }
                   deriving Int -> RPars -> ShowS
[RPars] -> ShowS
RPars -> String
(Int -> RPars -> ShowS)
-> (RPars -> String) -> ([RPars] -> ShowS) -> Show RPars
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RPars] -> ShowS
$cshowList :: [RPars] -> ShowS
show :: RPars -> String
$cshow :: RPars -> String
showsPrec :: Int -> RPars -> ShowS
$cshowsPrec :: Int -> RPars -> ShowS
Show

instance FromData RPars where
     fromData :: RqData RPars
fromData = do
         Maybe String
vtoken <- (String -> Maybe String) -> RqData String -> RqData (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (String -> RqData String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
look String
"token") RqData (Maybe String)
-> RqData (Maybe String) -> RqData (Maybe String)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String -> RqData (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
         Maybe String
vDestination <- (String -> Maybe String) -> RqData String -> RqData (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> ShowS -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
urlDecode) (String -> RqData String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
look String
"destination") RqData (Maybe String)
-> RqData (Maybe String) -> RqData (Maybe String)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                           Maybe String -> RqData (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
         RPars -> RqData RPars
forall (m :: * -> *) a. Monad m => a -> m a
return RPars :: Maybe String -> Maybe String -> RPars
RPars { rToken :: Maybe String
rToken = Maybe String
vtoken
                      , rDestination :: Maybe String
rDestination = Maybe String
vDestination }

rpxAuthHandlers :: [Handler]
rpxAuthHandlers :: [Handler]
rpxAuthHandlers =
  [ String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ Method -> GititServerPart ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET GititServerPart () -> Handler -> Handler
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Params -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login"  (Handler -> Handler) -> Handler -> Handler
forall a b. (a -> b) -> a -> b
$ (RPars -> Handler) -> Handler
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData RPars -> Handler
loginRPXUser
  , String -> Handler -> Handler
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]

-- | Returns username of logged in user or null string if nobody logged in.
currentUser :: Handler
currentUser :: Handler
currentUser = do
  Request
req <- ServerPartT (ReaderT WikiState IO) Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
  Response -> Handler
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ByteString -> String
toString (String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"REMOTE_USER" Request
req)