{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
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
substitute :: (Eq a) => [a] -> [a] -> [a] -> [a]
substitute :: forall a. Eq a => [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 forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
target' [a]
lst of
Just [a]
lst' -> [a]
replacement forall a. [a] -> [a] -> [a]
++ forall a. Eq a => [a] -> [a] -> [a] -> [a]
substitute [a]
target' [a]
replacement [a]
lst'
Maybe [a]
Nothing -> a
x forall 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
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]
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 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
"" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"resetPassword"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
fieldset forall a b. HTML a => (Html -> b) -> a -> b
<<
[ Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Username: "
, String -> Html
textfield String
"username" 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" 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
mailCommand Config
cfg)
then Html -> Html
p 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 " forall a. [a] -> [a] -> [a]
++
String
"or press the Back button to try again."]
Just User
u -> [String
"Since you did not register with " forall a. [a] -> [a] -> [a]
++
String
"an email address, we can't reset your password." |
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (User -> String
uEmail User
u) ]
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
then do
let response :: Html
response =
Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"An email has been sent to "
, Html -> Html
bold forall a b. (a -> b) -> a -> b
$ String -> Html
stringToHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> String
uEmail forall a b. (a -> b) -> a -> b
$ 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 (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 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl URL -> (String, String) -> URL
add_param
(forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe URL
importURL forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String
"/_doResetPassword")
[(String
"username", User -> String
uUsername User
user), (String
"reset_code", 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getHostName
String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
let messageTemplate :: StringTemplate String
messageTemplate = forall a. Stringable a => String -> StringTemplate a
T.newSTMP forall a b. (a -> b) -> a -> b
$ Config -> String
resetPasswordMessage Config
cfg
let filledTemplate :: String
filledTemplate = forall a. Stringable a => StringTemplate a -> a
T.render forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"username" (User -> String
uUsername User
user) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"useremail" (User -> String
uEmail User
user) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"hostname" String
hostname forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b.
(ToSElem a, Stringable b) =>
String -> a -> StringTemplate b -> StringTemplate b
T.setAttribute String
"port" (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Config -> Int
portNumber Config
cfg) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
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) forall a b. (a -> b) -> a -> b
$
StringTemplate String
messageTemplate
let (String
mailcommand:[String]
args) = String -> [String]
words forall a b. (a -> b) -> a -> b
$ 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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
mailcommand [String]
args
String
filledTemplate
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING forall a b. (a -> b) -> a -> b
$ String
"Sent reset password email to " forall a. [a] -> [a] -> [a]
++ User -> String
uUsername User
user forall a. [a] -> [a] -> [a]
++
String
" at " forall a. [a] -> [a] -> [a]
++ User -> String
uEmail User
user
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING forall a b. (a -> b) -> a -> b
$ String
mailcommand forall a. [a] -> [a] -> [a]
++ String
" failed. " 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 = forall a. Maybe a -> Bool
isJust Maybe User
user
let resetCodeMatches :: Bool
resetCodeMatches = forall a. Int -> [a] -> [a]
take Int
20 (Password -> String
pHashed (User -> Password
uPassword (forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
user))) 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 " forall a. [a] -> [a] -> [a]
++
forall html. HTML html => html -> String
renderHtmlFragment (String -> Html
stringToHtml String
uname) forall a. [a] -> [a] -> [a]
++
String
" is not known"]
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors
then User -> Handler
postValidate (forall a. HasCallStack => Maybe a -> a
fromJust Maybe User
user)
else GititServerPart Html
registerForm 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 forall a b. (a -> b) -> a -> b
$ \User
user ->
Maybe User -> GititServerPart Html
resetPasswordForm (forall a. a -> Maybe a
Just User
user) 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 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 (forall a. a -> Maybe a
Just User
user) 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' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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'
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING forall a b. (a -> b) -> a -> b
$
String
"Successfully reset password and email for " 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 forall a. Maybe a
Nothing
resetPasswordForm :: Maybe User -> GititServerPart Html
resetPasswordForm :: Maybe User -> GititServerPart Html
resetPasswordForm = Maybe User -> GititServerPart Html
sharedForm
sharedForm :: Maybe User -> GititServerPart Html
sharedForm :: Maybe User -> GititServerPart Html
sharedForm Maybe User
mbUser = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData 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
"" -> forall (m :: * -> *). ServerMonad m => m String
getReferer
String
x -> 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"accessCode"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
prompt forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br forall a b. (HTML a, HTML b) => a -> b -> Html
+++
String -> Html
X.password String
"accessCode" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"15", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
1]
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) 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] forall a b. HTML a => (Html -> b) -> a -> b
<<
String
"Username (at least 3 letters or digits):"
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br forall a b. (HTML a, HTML b) => a -> b -> Html
+++
String -> Html
textfield String
"username" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
2] forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br
Just User
user -> Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] forall a b. HTML a => (Html -> b) -> a -> b
<<
(String
"Username (cannot be changed): " forall a. [a] -> [a] -> [a]
++ User -> String
uUsername User
user)
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"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
gui String
"" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"loginForm"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
fieldset forall a b. HTML a => (Html -> b) -> a -> b
<<
[ Html
accessQ
, Html
userNameField
, Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"email"] 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" 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"req"]
, String -> Html
textfield String
"full_name_1" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
size String
"20", String -> HtmlAttr
theclass String
"req"]
, Html
br
, Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password"]
forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Password (at least 6 characters," forall a. [a] -> [a] -> [a]
++
String
" including at least one non-letter):")
, Html
br
, String -> Html
X.password String
"password" 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password2"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Confirm Password:"
, Html
br
, String -> Html
X.password String
"password2" 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" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle String
"display: none;", String -> HtmlAttr
value String
dest]
, Html
submitField 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 forall a. Eq a => a -> a -> Bool
== Char
' '
let isValidUsername :: t Char -> Bool
isValidUsername t Char
u = forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
u forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
pw forall a. Ord a => a -> a -> Bool
>= Int
6 Bool -> Bool -> Bool
&& Bool -> Bool
not (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
answers
let isValidEmail :: String -> Bool
isValidEmail String
e = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
==Char
'@') String
e) forall a. Eq a => a -> a -> Bool
== Int
1
String
peer <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Host
rqPeer) forall (m :: * -> *). ServerMonad m => m Request
askRq
Either String ()
captchaResult <-
if Config -> Bool
useRecaptcha Config
cfg
then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Recaptcha -> String
recaptchaChallengeField Recaptcha
recaptcha) Bool -> Bool -> Bool
||
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Recaptcha -> String
recaptchaResponseField Recaptcha
recaptcha)
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"missing-challenge-or-response"
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe String
mbIPaddr <- String -> IO (Maybe String)
lookupIPAddr String
peer
let ipaddr :: String
ipaddr = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find ip address for " forall a. [a] -> [a] -> [a]
++ String
peer)
Maybe String
mbIPaddr
String
ipaddr seq :: forall a b. a -> b -> b
`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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
let (Bool
validCaptcha, Maybe String
captchaError) =
case Either String ()
captchaResult of
Right () -> (Bool
True, forall a. Maybe a
Nothing)
Left String
err -> (Bool
False, forall a. a -> Maybe a
Just String
err)
let errors :: [String]
errors = [(Bool, String)] -> [String]
validate forall a b. (a -> b) -> a -> b
$ ValidationType -> [(Bool, String)]
optionalTests ValidationType
validationType forall a. [a] -> [a] -> [a]
++
[ (Bool -> Bool
not Bool
isValidAccessCode, String
"Incorrect response to access prompt.")
, (Bool -> Bool
not (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 (forall {t :: * -> *}. Foldable t => t Char -> Bool
isValidPassword String
pword),
String
"Password must be at least 6 characters, " forall a. [a] -> [a] -> [a]
++
String
"and must contain at least one non-letter.")
, (Bool -> Bool
not (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 forall a. Eq a => a -> a -> Bool
/= String
pword2,
String
"Password does not match confirmation.")
, (Bool -> Bool
not Bool
validCaptcha,
String
"Failed CAPTCHA (" forall a. [a] -> [a] -> [a]
++ forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
captchaError forall a. [a] -> [a] -> [a]
++
String
"). Are you really human?")
, (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fakeField),
String
"You do not seem human enough. If you're sure you are human, " forall a. [a] -> [a] -> [a]
++
String
"try turning off form auto-completion in your browser.")
]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors then forall a b. b -> Either a b
Right (String
uname, String
email, String
pword) else forall a b. a -> Either a b
Left [String]
errors
loginForm :: String -> GititServerPart Html
loginForm :: String -> GititServerPart Html
loginForm String
dest = do
Config
cfg <- GititServerPart Config
getConfig
String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
gui (String
base' forall a. [a] -> [a] -> [a]
++ String
"/_login") forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"loginForm"] forall a b. HTML a => (Html -> b) -> a -> b
<<
Html -> Html
fieldset forall a b. HTML a => (Html -> b) -> a -> b
<<
[ Html -> Html
label forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"username"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Username "
, String -> Html
textfield String
"username" 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 forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thefor String
"password"] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Password "
, String -> Html
X.password String
"password" 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" 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" forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> Int -> HtmlAttr
intAttr String
"tabindex" Int
3]
] forall a b. (HTML a, HTML b) => a -> b -> Html
+++
(if Config -> Bool
disableRegistration Config
cfg
then Html
noHtml
else Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"If you do not have an account, "
, Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String
"/_register?" forall a. [a] -> [a] -> [a]
++
[(String, String)] -> String
urlEncodeVars [(String
"destination", ShowS
encodeString String
dest)]] forall a b. HTML a => (Html -> b) -> a -> b
<< String
"click here to get one."
]) forall a b. (HTML a, HTML b) => a -> b -> Html
+++
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
mailCommand Config
cfg)
then Html
noHtml
else Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< [ String -> Html
stringToHtml String
"If you forgot your password, "
, Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String
"/_resetPassword"] forall a b. HTML a => (Html -> b) -> a -> b
<<
String
"click here to get a new one."
])
loginUserForm :: Handler
loginUserForm :: Handler
loginUserForm = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \Params
params -> do
String
dest <- case Params -> String
pDestination Params
params of
String
"" -> forall (m :: * -> *). ServerMonad m => m String
getReferer
String
x -> forall (m :: * -> *) a. Monad m => a -> m a
return String
x
String -> GititServerPart Html
loginForm String
dest 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 <- forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
uname)
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse forall a b. (a -> b) -> a -> b
$ Html -> Html
p forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"Welcome, " forall a. [a] -> [a] -> [a]
++
forall html. HTML html => html -> String
renderHtmlFragment (String -> Html
stringToHtml String
uname))
else
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
"" -> forall (m :: * -> *). ServerMonad m => m String
getReferer
String
x -> forall (m :: * -> *) a. Monad m => a -> m a
return String
x
case Maybe SessionKey
key of
Just SessionKey
k -> do
forall (m :: * -> *). MonadIO m => SessionKey -> m ()
delSession SessionKey
k
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie String
"sid"
Maybe SessionKey
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
dest) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse String
"You have been logged out."
registerUserForm :: Handler
registerUserForm :: Handler
registerUserForm = GititServerPart Html
registerForm 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 =
[ forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_register" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler
registerUserForm
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_register" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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) forall a. [a] -> [a] -> [a]
++
[ forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler
loginUserForm
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
loginUser
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_resetPassword" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPasswordRequestForm
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_resetPassword" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPasswordRequest
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_doResetPassword" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
resetPassword
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_doResetPassword" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
doResetPassword
, 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' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
let destination :: String
destination = Params -> String
pDestination Params
params forall a. [a] -> [a] -> [a]
`orIfNull` (String
base' forall a. [a] -> [a] -> [a]
++ String
"/")
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()
logoutUserHTTP :: Handler
logoutUserHTTP :: Handler
logoutUserHTTP = forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()
httpAuthHandlers :: [Handler]
httpAuthHandlers :: [Handler]
httpAuthHandlers =
[ forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" Handler
logoutUserHTTP
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
loginUserHTTP
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]
oauthGithubCallback :: GithubConfig
-> GithubCallbackPars
-> Handler
oauthGithubCallback :: GithubConfig -> GithubCallbackPars -> Handler
oauthGithubCallback GithubConfig
ghConfig GithubCallbackPars
githubCallbackPars =
forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Maybe SessionKey
sk :: Maybe SessionKey) ->
do
Maybe SessionData
mbSd <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall (m :: * -> *).
MonadIO m =>
SessionKey -> m (Maybe SessionData)
getSession Maybe SessionKey
sk
let mbGititState :: Maybe SessionGithubData
mbGititState = Maybe SessionData
mbSd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SessionData -> Maybe SessionGithubData
sessionGithubData
githubData :: SessionGithubData
githubData = forall a. a -> Maybe a -> a
fromMaybe (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' <- 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
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState forall a b. (a -> b) -> a -> b
$ \GititState
s -> GititState
s { users :: Map String User
users = 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 <- forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
userEmail)
Config
cfg <- GititServerPart Config
getConfig
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
destination) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()
Left GithubLoginError
err -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit" Priority
WARNING forall a b. (a -> b) -> a -> b
$ String
"Login Failed: " forall a. [a] -> [a] -> [a]
++ GithubLoginError -> String
ghUserMessage GithubLoginError
err forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
". Github response" 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 forall a. Ord a => a -> a -> Bool
>= AuthenticationLevel
ForRead = String
base' forall a. [a] -> [a] -> [a]
++ String
"/_loginFailure"
| Bool
otherwise = String
destination
let url :: String
url = String
destination' forall a. [a] -> [a] -> [a]
++ String
"?message=" forall a. [a] -> [a] -> [a]
++ GithubLoginError -> String
ghUserMessage GithubLoginError
err
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
url) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()
githubAuthHandlers :: GithubConfig
-> [Handler]
githubAuthHandlers :: GithubConfig -> [Handler]
githubAuthHandlers GithubConfig
ghConfig =
[ forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ OAuth2 -> Params -> Handler
loginGithubUser forall a b. (a -> b) -> a -> b
$ GithubConfig -> OAuth2
oAuth2 GithubConfig
ghConfig
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_loginFailure" forall a b. (a -> b) -> a -> b
$ Handler
githubLoginFailure
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_githubCallback" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ GithubConfig -> GithubCallbackPars -> Handler
oauthGithubCallback GithubConfig
ghConfig
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]
githubLoginFailure :: Handler
githubLoginFailure :: Handler
githubLoginFailure = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \Params
params ->
PageLayout -> Html -> Handler
formattedPage ([String] -> PageLayout
pageLayout (Params -> [String]
pMessages Params
params)) Html
noHtml forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
}
loginRPXUser :: RPars
-> Handler
loginRPXUser :: RPars -> Handler
loginRPXUser RPars
params = do
Config
cfg <- GititServerPart Config
getConfig
String
ref <- forall (m :: * -> *). ServerMonad m => m String
getReferer
let mtoken :: Maybe String
mtoken = RPars -> Maybe String
rToken RPars
params
if forall a. Maybe a -> Bool
isNothing Maybe String
mtoken
then do
let url :: String
url = Config -> String
baseUrl Config
cfg forall a. [a] -> [a] -> [a]
++ String
"/_login?destination=" forall a. [a] -> [a] -> [a]
++
forall a. a -> Maybe a -> a
fromMaybe String
ref (RPars -> Maybe String
rDestination RPars
params)
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Config -> String
rpxDomain Config
cfg)
then forall a. HasCallStack => String -> a
error String
"rpx-domain is not set."
else do
let rpx :: String
rpx = String
"https://" forall a. [a] -> [a] -> [a]
++ Config -> String
rpxDomain Config
cfg forall a. [a] -> [a] -> [a]
++
String
".rpxnow.com/openid/v2/signin?token_url=" forall a. [a] -> [a] -> [a]
++
ShowS
urlEncode String
url
forall {m :: * -> *}.
FilterMonad Response m =>
String -> m Response
see String
rpx
else do
Either String Identifier
uid' :: Either String R.Identifier <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
String -> String -> IO (Either String Identifier)
R.authenticate (Config -> String
rpxKey Config
cfg) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
mtoken
Identifier
uid <- case Either String Identifier
uid' of
Right Identifier
u -> forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
u
Left String
err -> forall a. HasCallStack => String -> a
error String
err
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"gitit.loginRPXUser" Priority
DEBUG forall a b. (a -> b) -> a -> b
$ String
"uid:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
uid
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO User
mkUser (forall a. a -> Maybe a -> a
fromMaybe String
userId Maybe String
email) (forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
email) String
"none"
forall (m :: * -> *).
MonadIO m =>
(GititState -> GititState) -> m ()
updateGititState forall a b. (a -> b) -> a -> b
$ \GititState
s -> GititState
s { users :: Map String User
users = 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 <- forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (String -> SessionData
sessionData String
userId)
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
forall {m :: * -> *}.
FilterMonad Response m =>
String -> m Response
see forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ RPars -> Maybe String
rDestination RPars
params
where
prop :: String -> Identifier -> Maybe String
prop String
pname Identifier
info = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname forall a b. (a -> b) -> a -> b
$ Identifier -> [(String, String)]
R.userData Identifier
info
see :: String -> m Response
see String
url = forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ShowS
encUrl String
url) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse Html
noHtml
data RPars = RPars { RPars -> Maybe String
rToken :: Maybe String
, RPars -> Maybe String
rDestination :: Maybe String }
deriving Int -> RPars -> ShowS
[RPars] -> ShowS
RPars -> String
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 <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just (forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
look String
"token") forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe String
vDestination <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
urlDecode) (forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
look String
"destination") forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return RPars { rToken :: Maybe String
rToken = Maybe String
vtoken
, rDestination :: Maybe String
rDestination = Maybe String
vDestination }
rpxAuthHandlers :: [Handler]
rpxAuthHandlers :: [Handler]
rpxAuthHandlers =
[ forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_logout" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData Params -> Handler
logoutUser
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_login" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData RPars -> Handler
loginRPXUser
, forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"_user" Handler
currentUser ]
currentUser :: Handler
currentUser :: Handler
currentUser = do
Request
req <- forall (m :: * -> *). ServerMonad m => m Request
askRq
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ByteString -> String
toString (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"REMOTE_USER" Request
req)