    {-# 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 Text.Pandoc.Shared (substitute)
    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

    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
    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 errors :: [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 = "Register for an account"
                              }
        Right (uname :: String
    uname, email :: String
    email, pword :: 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 _ = do
      let passwordForm :: Html
    passwordForm = String -> Html -> Html
    gui "" (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    identifier "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 "username"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "Username: "
                  , String -> Html
    textfield "username" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> Int -> HtmlAttr
    intAttr "tabindex" 1], String -> Html
    stringToHtml " "
                  , String -> String -> Html
    submit "resetPassword" "Reset Password" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> Int -> HtmlAttr
    intAttr "tabindex" 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
    << "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 = "Reset your password" }
                    Html
    contents

    resetPasswordRequest :: Params -> Handler
    resetPasswordRequest :: Params -> Handler
    resetPasswordRequest params :: 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
            Nothing -> ["Unknown user. Please re-register " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                        "or press the Back button to try again."]
            Just u :: User
    u  -> ["Since you did not register with " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                       "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 "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
                       "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 = "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 = "Register for an account"
                             }

    resetLink :: String -> User -> String
    resetLink :: String -> User -> String
    resetLink base' :: String
    base' user :: 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]
    ++ "/_doResetPassword")
        [("username", User -> String
    uUsername User
    user), ("reset_code", Int -> ShowS
    forall a. Int -> [a] -> [a]
    take 20 (Password -> String
    pHashed (User -> Password
    uPassword User
    user)))]

    sendReregisterEmail :: User -> GititServerPart ()
    sendReregisterEmail :: User -> GititServerPart ()
    sendReregisterEmail user :: 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 "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 "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 "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 "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 "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 (mailcommand :: String
    mailcommand:args :: [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 "%s" (User -> String
    uEmail User
    user)
                                       (Config -> String
    mailCommand Config
    cfg)
      (exitCode :: ExitCode
    exitCode, _pOut :: String
    _pOut, pErr :: 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 "gitit" Priority
    WARNING (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "Sent reset password email to " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ User -> String
    uUsername User
    user String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                             " 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 "gitit" Priority
    WARNING (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    mailcommand String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " failed. " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    pErr

    validateReset :: Params -> (User -> Handler) -> Handler
    validateReset :: Params -> (User -> Handler) -> Handler
    validateReset params :: Params
    params postValidate :: 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 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
                         (True, True)   -> []
                         (True, False)  -> ["Your reset code is invalid"]
                         (False, _)     -> ["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]
    ++
                           " 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 = "Register for an account"
                              }

    resetPassword :: Params -> Handler
    resetPassword :: Params -> Handler
    resetPassword params :: Params
    params = Params -> (User -> Handler) -> Handler
    validateReset Params
    params ((User -> Handler) -> Handler) -> (User -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \user :: 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 = "Reset your registration info"
                      }

    doResetPassword :: Params -> Handler
    doResetPassword :: Params -> Handler
    doResetPassword params :: Params
    params = Params -> (User -> Handler) -> Handler
    validateReset Params
    params ((User -> Handler) -> Handler) -> (User -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \user :: 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 errors :: [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 = "Reset your registration info"
                              }
        Right (uname :: String
    uname, email :: String
    email, pword :: 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 "gitit" Priority
    WARNING (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                "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 mbUser :: 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
    params -> do
      Config
    cfg <- GititServerPart Config
    getConfig
      String
    dest <- case Params -> String
    pDestination Params
    params of
                    ""  -> ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getReferer
                    x :: 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 _ -> Html
    noHtml
                Nothing -> case Config -> Maybe (String, [String])
    accessQuestion Config
    cfg of
                          Nothing          -> Html
    noHtml
                          Just (prompt :: String
    prompt, _) -> Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "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 "accessCode" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "15", String -> Int -> HtmlAttr
    intAttr "tabindex" 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 field :: User -> String
    field = case Maybe User
    mbUser of
                          Nothing    -> ""
                          Just user :: User
    user  -> User -> String
    field User
    user
      let userNameField :: Html
    userNameField = case Maybe User
    mbUser of
                          Nothing    -> Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "username"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    <<
                                         "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 "username" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> Int -> HtmlAttr
    intAttr "tabindex" 2] Html -> Html -> Html
    forall a b. (HTML a, HTML b) => a -> b -> Html
    +++ Html
    br
                          Just user :: User
    user  -> Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "username"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    <<
                                        ("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
                          Nothing    -> String -> String -> Html
    submit "register" "Register"
                          Just _     -> String -> String -> Html
    submit "resetPassword" "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 "" (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    identifier "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 "email"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "Email (optional, will not be displayed on the Wiki):"
                , Html
    br
                , String -> Html
    textfield "email" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> Int -> HtmlAttr
    intAttr "tabindex" 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 "req"]
                , String -> Html
    textfield "full_name_1" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> HtmlAttr
    theclass "req"]
                , Html
    br
                , Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "password"]
                        (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << ("Password (at least 6 characters," String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                            " including at least one non-letter):")
                , Html
    br
                , String -> Html
    X.password "password" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> Int -> HtmlAttr
    intAttr "tabindex" 4]
                , String -> Html
    stringToHtml " "
                , Html
    br
                , Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "password2"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "Confirm Password:"
                , Html
    br
                , String -> Html
    X.password "password2" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "20", String -> Int -> HtmlAttr
    intAttr "tabindex" 5]
                , String -> Html
    stringToHtml " "
                , Html
    br
                , Html
    captcha
                , String -> Html
    textfield "destination" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thestyle "display: none;", String -> HtmlAttr
    value String
    dest]
                , Html
    submitField Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> Int -> HtmlAttr
    intAttr "tabindex" 6]]

    sharedValidation :: ValidationType
                     -> Params
                     -> GititServerPart (Either [String] (String,String,String))
    sharedValidation :: ValidationType
    -> Params
    -> GititServerPart (Either [String] (String, String, String))
    sharedValidation validationType :: ValidationType
    validationType params :: Params
    params = do
      let isValidUsernameChar :: Char -> Bool
    isValidUsernameChar c :: Char
    c = Char -> Bool
    isAlphaNum Char
    c Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == ' '
      let isValidUsername :: t Char -> Bool
    isValidUsername u :: 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
    >= 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 pw :: 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
    >= 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 Register =
              [(Bool
    taken, "Sorry, that username is already taken.")]
          optionalTests ResetPassword = []
      let isValidAccessCode :: Bool
    isValidAccessCode = case ValidationType
    validationType of
            ResetPassword -> Bool
    True
            Register -> case Config -> Maybe (String, [String])
    accessQuestion Config
    cfg of
                Nothing           -> Bool
    True
                Just (_, answers :: [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 e :: 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
    =='@') String
    e) Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 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 "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
    $ "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 ())
    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 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 (validCaptcha :: Bool
    validCaptcha, captchaError :: Maybe String
    captchaError) =
            case Either String ()
    captchaResult of
                  Right () -> (Bool
    True, Maybe String
    forall a. Maybe a
    Nothing)
                  Left err :: 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, "Incorrect response to access prompt.")
            , (Bool -> Bool
    not (String -> Bool
    forall (t :: * -> *). Foldable t => t Char -> Bool
    isValidUsername String
    uname),
             "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),
             "Password must be at least 6 characters, " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
             "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),
             "Email address appears invalid.")
            , (String
    pword String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    pword2,
            "Password does not match confirmation.")
            , (Bool -> Bool
    not Bool
    validCaptcha,
            "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]
    ++
            "). 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)
            "You do not seem human enough. If you're sure you are human, " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
            "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 dest :: 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]
    ++ "/_login") (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    identifier "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 "username"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "Username "
          , String -> Html
    textfield "username" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "15", String -> Int -> HtmlAttr
    intAttr "tabindex" 1]
          , String -> Html
    stringToHtml " "
          , Html -> Html
    label (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thefor "password"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "Password "
          , String -> Html
    X.password "password" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    size "15", String -> Int -> HtmlAttr
    intAttr "tabindex" 2]
          , String -> Html
    stringToHtml " "
          , String -> Html
    textfield "destination" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thestyle "display: none;", String -> HtmlAttr
    value String
    dest]
          , String -> String -> Html
    submit "login" "Login" Html -> [HtmlAttr] -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> Int -> HtmlAttr
    intAttr "tabindex" 3]
          ] Html -> Html -> Html
    forall a b. (HTML a, HTML b) => a -> b -> Html
    +++
        Html -> Html
    p (Html -> Html) -> [Html] -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << [ String -> Html
    stringToHtml "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]
    ++ "/_register?" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
               [(String, String)] -> String
    urlEncodeVars [("destination", ShowS
    encodeString String
    dest)]] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << "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 "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]
    ++ "/_resetPassword"] (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    <<
                         "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
    params -> do
      String
    dest <- case Params -> String
    pDestination Params
    params of
                    ""  -> ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getReferer
                    x :: 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 = "Login",
                                         pgMessages :: [String]
    pgMessages = Params -> [String]
    pMessages Params
    params
                                       }

    loginUser :: Params -> Handler
    loginUser :: Params -> Handler
    loginUser params :: 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) (String -> String -> Cookie
    mkCookie "sid" (SessionKey -> String
    forall a. Show a => a -> String
    show 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
    << ("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 ["Invalid username or password."] Handler
    loginUserForm

    logoutUser :: Params -> Handler
    logoutUser :: Params -> Handler
    logoutUser params :: Params
    params = do
      let key :: Maybe SessionKey
    key = Params -> Maybe SessionKey
    pSessionKey Params
    params
      String
    dest <- case Params -> String
    pDestination Params
    params of
                    ""  -> ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getReferer
                    x :: 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 k :: 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 "sid"
           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 "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 = "Register for an account"
                        }

    formAuthHandlers :: [Handler]
    formAuthHandlers :: [Handler]
    formAuthHandlers =
      [ String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    dir "_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 "_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
      , String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    dir "_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 "_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 "_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 "_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 "_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 "_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 "_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 "_user" Handler
    currentUser
      ]

    loginUserHTTP :: Params -> Handler
    loginUserHTTP :: Params -> Handler
    loginUserHTTP params :: 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 -> 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 "_logout" Handler
    logoutUserHTTP
      , String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    dir "_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 "_user" Handler
    currentUser ]

    oauthGithubCallback :: GithubConfig
                       -> GithubCallbackPars                  -- ^ Authentication code gained after authorization
                       -> Handler
    oauthGithubCallback :: GithubConfig -> GithubCallbackPars -> Handler
    oauthGithubCallback ghConfig :: GithubConfig
    ghConfig githubCallbackPars :: 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 "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
    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
    $ \s :: 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) (String -> String -> Cookie
    mkCookie "sid" (SessionKey -> String
    forall a. Show a => a -> String
    show 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 err :: 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 "gitit" Priority
    WARNING (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "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 "" (". 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]
    ++ "/_loginFailure"
                        | Bool
    otherwise                            = String
    destination
                  let url :: String
    url = String
    destination' String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "?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 ghConfig :: GithubConfig
    ghConfig =
      [ String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    dir "_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 "_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 "_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 "_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 "_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
    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 msgs :: [String]
    msgs =
          PageLayout
    defaultPageLayout{ pgShowPageTools :: Bool
    pgShowPageTools = Bool
    False,
                             pgTabs :: [Tab]
    pgTabs = [],
                             pgTitle :: String
    pgTitle = "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 params :: 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]
    ++ "/_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 "rpx-domain is not set."
              else do
                 let rpx :: String
    rpx = "https://" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Config -> String
    rpxDomain Config
    cfg String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                           ".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 u :: Identifier
    u -> Identifier -> ServerPartT (ReaderT WikiState IO) Identifier
    forall (m :: * -> *) a. Monad m => a -> m a
    return Identifier
    u
                       Left err :: 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 "gitit.loginRPXUser" Priority
    DEBUG (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "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 "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 "" Maybe String
    email) "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
    $ \s :: 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) (String -> String -> Cookie
    mkCookie "sid" (SessionKey -> String
    forall a. Show a => a -> String
    show 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 pname :: String
    pname info :: 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 url :: 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 "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 "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 "_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 "_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 "_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 "" ByteString -> String
    toString (String -> Request -> Maybe ByteString
    forall r. HasHeaders r => String -> r -> Maybe ByteString
    getHeader "REMOTE_USER" Request
    req)