    {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-
    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
                                        , 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 System.Process (readProcessWithExitCode)
    import Control.Monad (unless, liftM)
    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, fromMaybe)
    import Network.URL (exportURL, add_param, importURL)
    import Network.BSD (getHostName)
    import qualified Text.StringTemplate as T
    import Network.HTTP (urlEncodeVars)
    import Codec.Binary.UTF8.String (encodeString)
    import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml )
    import Text.Blaze.Html5 hiding (i, search, u, s, contents, source, html, title, map)
    import qualified Text.Blaze.Html5 as Html5 hiding (search)
    import qualified Text.Blaze.Html5.Attributes as Html5.Attr hiding (dir, span)
    import Text.Blaze.Html5.Attributes
    import Data.String (IsString(fromString))
    import qualified Text.XHtml as XHTML
    import Data.ByteString.UTF8 (toString)

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

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

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

    gui :: AttributeValue -> Html -> Html
    gui :: AttributeValue -> Html -> Html
    gui AttributeValue
    act = Html -> Html
    Html5.form (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.action AttributeValue
    act (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.method AttributeValue
    "post"

    textfieldInput :: AttributeValue -> AttributeValue -> Html
    textfieldInput :: AttributeValue -> AttributeValue -> Html
    textfieldInput AttributeValue
    nameAndId AttributeValue
    val = Html
    input Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    type_ AttributeValue
    "text" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.id AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    name AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    value AttributeValue
    val
    textfieldInput' :: AttributeValue -> Html
    textfieldInput' :: AttributeValue -> Html
    textfieldInput' AttributeValue
    nameAndId = Html
    input Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    type_ AttributeValue
    "text" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.id AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    name AttributeValue
    nameAndId
    passwordInput :: AttributeValue -> Html
    passwordInput :: AttributeValue -> Html
    passwordInput AttributeValue
    nameAndId = Html
    input Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    type_ AttributeValue
    "password" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.id AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    name AttributeValue
    nameAndId
    submitInput :: AttributeValue -> AttributeValue -> Html
    submitInput :: AttributeValue -> AttributeValue -> Html
    submitInput AttributeValue
    nameAndId AttributeValue
    val = Html
    input Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    type_ AttributeValue
    "submit" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.id AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    name AttributeValue
    nameAndId Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    value AttributeValue
    val

    intTabindex :: Int -> Attribute
    intTabindex :: Int -> Attribute
    intTabindex Int
    i = AttributeValue -> Attribute
    Html5.Attr.tabindex (String -> AttributeValue
    forall a. IsString a => String -> a
    fromString (String -> AttributeValue) -> String -> AttributeValue
    forall a b. (a -> b) -> a -> b
    $ Int -> String
    forall a. Show a => a -> String
    show Int
    i)

    resetPasswordRequestForm :: Params -> Handler
    resetPasswordRequestForm :: Params -> Handler
    resetPasswordRequestForm Params
    _ = do
      let passwordForm :: Html
    passwordForm = AttributeValue -> Html -> Html
    gui AttributeValue
    "" (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.id AttributeValue
    "resetPassword" (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Html -> Html
    fieldset (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ [Html] -> Html
    forall a. Monoid a => [a] -> a
    mconcat
                  [ Html -> Html
    Html5.label (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.for AttributeValue
    "username" (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Html
    "Username: "
                  , AttributeValue -> Html
    textfieldInput' AttributeValue
    "username" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    size AttributeValue
    "20" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! Int -> Attribute
    intTabindex Int
    1
                  , Html
    " "
                  , AttributeValue -> AttributeValue -> Html
    submitInput AttributeValue
    "resetPassword" AttributeValue
    "Reset Password" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! Int -> Attribute
    intTabindex Int
    2]
      cfg <- GititServerPart Config
    getConfig
      let contents = if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Config -> String
    mailCommand Config
    cfg)
                        then Html -> Html
    p (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Html
    "Sorry, password reset not available."
                        else Html
    passwordForm
      formattedPage defaultPageLayout{
                      pgShowPageTools = False,
                      pgTabs = [],
                      pgTitle = "Reset your password" }
                    contents

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

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

    sendReregisterEmail :: User -> GititServerPart ()
    sendReregisterEmail :: User -> GititServerPart ()
    sendReregisterEmail User
    user = do
      cfg <- GititServerPart Config
    getConfig
      hostname <- liftIO getHostName
      base' <- getWikiBase
      let 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 = StringTemplate String -> String
    forall a. Stringable a => StringTemplate a -> a
    T.render (StringTemplate String -> String)
    -> (StringTemplate String -> StringTemplate String)
    -> StringTemplate String
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           String -> String -> StringTemplate String -> StringTemplate String
    forall a b.
    (ToSElem a, Stringable b) =>
    String -> a -> StringTemplate b -> StringTemplate b
    T.setAttribute String
    "username" (User -> String
    uUsername User
    user) (StringTemplate String -> StringTemplate String)
    -> (StringTemplate String -> StringTemplate String)
    -> StringTemplate String
    -> StringTemplate String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           String -> String -> StringTemplate String -> StringTemplate String
    forall a b.
    (ToSElem a, Stringable b) =>
    String -> a -> StringTemplate b -> StringTemplate b
    T.setAttribute String
    "useremail" (User -> String
    uEmail User
    user) (StringTemplate String -> StringTemplate String)
    -> (StringTemplate String -> StringTemplate String)
    -> StringTemplate String
    -> StringTemplate String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           String -> String -> StringTemplate String -> StringTemplate String
    forall a b.
    (ToSElem a, Stringable b) =>
    String -> a -> StringTemplate b -> StringTemplate b
    T.setAttribute String
    "hostname" String
    hostname (StringTemplate String -> StringTemplate String)
    -> (StringTemplate String -> StringTemplate String)
    -> StringTemplate String
    -> StringTemplate String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           String -> String -> StringTemplate String -> StringTemplate String
    forall a b.
    (ToSElem a, Stringable b) =>
    String -> a -> StringTemplate b -> StringTemplate b
    T.setAttribute String
    "port" (Int -> String
    forall a. Show a => a -> String
    show (Int -> String) -> Int -> String
    forall a b. (a -> b) -> a -> b
    $ Config -> Int
    portNumber Config
    cfg) (StringTemplate String -> StringTemplate String)
    -> (StringTemplate String -> StringTemplate String)
    -> StringTemplate String
    -> StringTemplate String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                           String -> String -> StringTemplate String -> StringTemplate String
    forall a b.
    (ToSElem a, Stringable b) =>
    String -> a -> StringTemplate b -> StringTemplate b
    T.setAttribute String
    "resetlink" (String -> User -> String
    resetLink String
    base' User
    user) (StringTemplate String -> String)
    -> StringTemplate String -> String
    forall a b. (a -> b) -> a -> b
    $
                           StringTemplate String
    messageTemplate
      let (mailcommand:args) = words $ substitute "%s" (uEmail user)
                                       (mailCommand cfg)
      (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args
                                          filledTemplate
      liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user ++
                             " at " ++ uEmail user
      unless (exitCode == ExitSuccess) $
        liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ 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
      user <- String -> GititServerPart (Maybe User)
    getUser String
    uname
      let knownUser = Maybe User -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe User
    user
      let resetCodeMatches = Int -> ShowS
    forall a. Int -> [a] -> [a]
    take Int
    20 (Password -> String
    pHashed (User -> Password
    uPassword (Maybe User -> User
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe User
    user))) String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==
                               Params -> String
    pResetCode Params
    params
      let errors = case (Bool
    knownUser, Bool
    resetCodeMatches) of
                         (Bool
    True, Bool
    True)   -> []
                         (Bool
    True, Bool
    False)  -> [String
    "Your reset code is invalid"]
                         (Bool
    False, Bool
    _)     -> [String
    "User " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                           Html -> String
    renderHtml (String -> Html
    forall a. IsString a => String -> a
    fromString String
    uname) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                           String
    " is not known"]
      if null errors
         then postValidate (fromJust user)
         else registerForm >>=
              formattedPage defaultPageLayout{
                              pgMessages = errors,
                              pgShowPageTools = False,
                              pgTabs = [],
                              pgTitle = "Register for an account"
                              }

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

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

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

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

    sharedForm :: Maybe User -> GititServerPart Html
    sharedForm :: Maybe User -> GititServerPart Html
    sharedForm Maybe User
    mbUser = (Params -> GititServerPart Html) -> GititServerPart Html
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Params -> GititServerPart Html) -> GititServerPart Html)
    -> (Params -> GititServerPart Html) -> GititServerPart Html
    forall a b. (a -> b) -> a -> b
    $ \Params
    params -> do
      cfg <- GititServerPart Config
    getConfig
      dest <- case pDestination params of
                    String
    ""  -> ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getReferer
                    String
    x   -> String -> ServerPartT (ReaderT WikiState IO) String
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    x
      let accessQ = case Maybe User
    mbUser of
                Just User
    _ -> Html
    forall a. Monoid a => a
    mempty
                Maybe User
    Nothing -> case Config -> Maybe (String, [String])
    accessQuestion Config
    cfg of
                          Maybe (String, [String])
    Nothing          -> Html
    forall a. Monoid a => a
    mempty
                          Just (String
    prompt, [String]
    _) -> [Html] -> Html
    forall a. Monoid a => [a] -> a
    mconcat
                            [ Html -> Html
    Html5.label (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.for AttributeValue
    "accessCode" (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ String -> Html
    forall a. IsString a => String -> a
    fromString String
    prompt
                            , Html
    br
                            , AttributeValue -> Html
    passwordInput AttributeValue
    "accessCode" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    size AttributeValue
    "15" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! Int -> Attribute
    intTabindex Int
    1
                            , Html
    br
                            ]
      let 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
    forall a. Monoid a => a
    mempty
      let initField User -> a
    field = case Maybe User
    mbUser of
                          Maybe User
    Nothing    -> a
    ""
                          Just User
    user  -> User -> a
    field User
    user
      let userNameField = case Maybe User
    mbUser of
                          Maybe User
    Nothing    -> [Html] -> Html
    forall a. Monoid a => [a] -> a
    mconcat
                            [ Html -> Html
    Html5.label (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.for AttributeValue
    "username" (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Html
    "Username (at least 3 letters or digits):"
                            , Html
    br
                            , AttributeValue -> Html
    textfieldInput' AttributeValue
    "username" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    size AttributeValue
    "20" Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! Int -> Attribute
    intTabindex Int
    2
                            , Html
    br
                            ]
                          Just User
    user  -> Html -> Html
    Html5.label (Html -> Html) -> Attribute -> Html -> Html
    forall h. Attributable h => h -> Attribute -> h
    ! AttributeValue -> Attribute
    Html5.Attr.for AttributeValue
    "username" (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $
                                        (String -> Html
    forall a. IsString a => String -> a
    fromString (String -> Html) -> String -> Html
    forall a b. (a -> b) -> a -> b
    $ String
    "Username (cannot be changed): " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ User -> String
    uUsername User
    user)
                                        Html -> Html -> Html
    forall a. Semigroup a => a -> a -> a
    <> Html
    br
      let submitField = case Maybe User
    mbUser of
                          Maybe User
    Nothing    -> AttributeValue -> AttributeValue -> Html
    submitInput AttributeValue
    "register" AttributeValue
    "Register"
                          Just User
    _     -> AttributeValue -> AttributeValue -> Html
    submitInput AttributeValue
    "resetPassword" AttributeValue
    "Reset Password"

      return $ gui "" ! Html5.Attr.id "loginForm" $ fieldset $ mconcat
                [ accessQ
                , userNameField
                , Html5.label ! Html5.Attr.for "email" $ "Email (optional, will not be displayed on the Wiki):"
                , br
                , textfieldInput "email" (fromString $ initField uEmail) ! size "20" ! intTabindex 3
                , br ! class_ "req"
                , textfieldInput' "full_name_1" ! size "20" ! class_ "req"
                , br
                , Html5.label ! Html5.Attr.for "password"
                        $ fromString ("Password (at least 6 characters," ++
                            " including at least one non-letter):")
                , br
                , passwordInput "password" ! size "20" ! intTabindex 4
                , " "
                , br
                , Html5.label ! Html5.Attr.for "password2" $ "Confirm Password:"
                , br
                , passwordInput "password2" ! size "20" ! intTabindex 5
                , " "
                , br
                -- Workaround, as ReCaptcha does not work with BlazeHtml
                , preEscapedToHtml (XHTML.renderHtmlFragment captcha)
                , textfieldInput "destination" (fromString dest) ! Html5.Attr.style "display: none;"
                , submitField ! intTabindex 6
                ]

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

    -- user authentication
    loginForm :: String -> GititServerPart Html
    loginForm :: String -> GititServerPart Html
    loginForm String
    dest = do
      cfg <- GititServerPart Config
    getConfig
      base' <- getWikiBase
      return $ gui (fromString $ base' ++ "/_login") ! Html5.Attr.id "loginForm" $
        (fieldset $ mconcat
          [ Html5.label ! Html5.Attr.for "username" $ "Username "
          , textfieldInput' "username" ! size "15" ! intTabindex 1
          , " "
          , Html5.label ! Html5.Attr.for "password" $ "Password "
          , passwordInput "password" ! size "15" ! intTabindex 2
          , " "
          , textfieldInput "destination" (fromString dest) ! Html5.Attr.style "display: none;"
          , submitInput "login" "Login" ! intTabindex 3
          ]) <>
        (if disableRegistration cfg
           then mempty
           else p $ mconcat
                     [ "If you do not have an account, "
                     , a ! href (fromString $ base' ++ "/_register?" ++
                         urlEncodeVars [("destination", encodeString dest)]) $ "click here to get one."
                     ]) <>
        (if null (mailCommand cfg)
           then mempty
           else p $ mconcat
                     [ "If you forgot your password, "
                     , a ! href (fromString $ base' ++ "/_resetPassword") $
                         "click here to get a new one."
                     ])

    loginUserForm :: Handler
    loginUserForm :: Handler
    loginUserForm = (Params -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData ((Params -> Handler) -> Handler) -> (Params -> Handler) -> Handler
    forall a b. (a -> b) -> a -> b
    $ \Params
    params -> do
      dest <- case Params -> String
    pDestination Params
    params of
                    String
    ""  -> ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getReferer
                    String
    x   -> String -> ServerPartT (ReaderT WikiState IO) String
    forall a. a -> ServerPartT (ReaderT WikiState IO) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    x
      loginForm dest >>=
        formattedPage defaultPageLayout{ pgShowPageTools = False,
                                         pgTabs = [],
                                         pgTitle = "Login",
                                         pgMessages = pMessages 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
      allowed <- String -> String -> GititServerPart Bool
    authUser String
    uname String
    pword
      cfg <- getConfig
      if allowed
        then do
          key <- newSession (sessionData uname)
          addCookie (MaxAge $ sessionTimeout cfg) (mkSessionCookie key)
          seeOther (encUrl destination) $ toResponse $ p $ (fromString $ "Welcome, " ++ uname)
        else
          withMessages ["Invalid username or password."] loginUserForm

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

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

    regAuthHandlers :: [Handler]
    regAuthHandlers :: [Handler]
    regAuthHandlers =
      [ String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    Network.Gitit.Server.dir String
    "_register"  (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    GET GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_register"  (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    POST GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (Params -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData Params -> Handler
    registerUser
      ]

    formAuthHandlers :: Bool -> [Handler]
    formAuthHandlers :: Bool -> [Handler]
    formAuthHandlers Bool
    disableReg =
      (if Bool
    disableReg
        then []
        else [Handler]
    regAuthHandlers) [Handler] -> [Handler] -> [Handler]
    forall a. [a] -> [a] -> [a]
    ++
      [ String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    Network.Gitit.Server.dir String
    "_login"     (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    GET  GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_login"     (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    POST GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_logout"    (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    GET  GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_resetPassword"   (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    GET  GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_resetPassword"   (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    POST GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_doResetPassword" (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    GET  GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_doResetPassword" (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ Method -> GititServerPart ()
    forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    method -> m ()
    Network.Gitit.Server.method Method
    POST GititServerPart () -> Handler -> Handler
    forall a b.
    ServerPartT (ReaderT WikiState IO) a
    -> ServerPartT (ReaderT WikiState IO) b
    -> ServerPartT (ReaderT WikiState IO) b
    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
    Network.Gitit.Server.dir String
    "_user" Handler
    currentUser
      ]

    loginUserHTTP :: Params -> Handler
    loginUserHTTP :: Params -> Handler
    loginUserHTTP Params
    params = do
      base' <- ServerPartT (ReaderT WikiState IO) String
    forall (m :: * -> *). ServerMonad m => m String
    getWikiBase
      let destination = Params -> String
    pDestination Params
    params String -> ShowS
    forall a. [a] -> [a] -> [a]
    `orIfNull` (String
    base' String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "/")
      seeOther (encUrl destination) $ 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
    Network.Gitit.Server.dir String
    "_logout" Handler
    logoutUserHTTP
      , String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    Network.Gitit.Server.dir String
    "_login"  (Handler -> Handler) -> Handler -> Handler
    forall a b. (a -> b) -> a -> b
    $ (Params -> Handler) -> Handler
    forall (m :: * -> *) a r.
    (HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
    (a -> m r) -> m r
    withData Params -> Handler
    loginUserHTTP
      , String -> Handler -> Handler
    forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    Network.Gitit.Server.dir String
    "_user" Handler
    currentUser ]

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

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

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

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