{-# LANGUAGE ScopedTypeVariables #-}
module Network.Gitit.Framework (
withUserFromSession
, withUserFromHTTPAuth
, authenticateUserThat
, authenticate
, getLoggedInUser
, unlessNoEdit
, unlessNoDelete
, guardCommand
, guardPath
, guardIndex
, guardBareBase
, getPath
, getPage
, getReferer
, getWikiBase
, uriPath
, isPage
, isPageFile
, isDiscussPage
, isDiscussPageFile
, isNotDiscussPageFile
, isSourceCode
, withMessages
, urlForPage
, pathForPage
, getMimeTypeForExtension
, validate
, filestoreFromConfig
, mkSessionCookie
)
where
import Safe
import Network.Gitit.Server
import Network.Gitit.State
import Network.Gitit.Types
import Data.FileStore
import Data.Char (toLower)
import Control.Monad (mzero, liftM, unless)
import qualified Data.Map as M
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8
import Skylighting (syntaxesByFilename, defaultSyntaxMap)
import Data.Maybe (fromJust, fromMaybe)
import Data.List (intercalate, isPrefixOf, isInfixOf)
import System.FilePath ((<.>), takeExtension, takeFileName)
import Text.ParserCombinators.Parsec
import Network.URL (decString, encString)
import Network.URI (isUnescapedInURI)
import Data.ByteString.Base64 (decodeLenient)
import Network.HTTP (urlEncodeVars)
authenticate :: AuthenticationLevel -> Handler -> Handler
authenticate :: AuthenticationLevel -> Handler -> Handler
authenticate = (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
authenticateUserThat (forall a b. a -> b -> a
const Bool
True)
authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
authenticateUserThat User -> Bool
predicate AuthenticationLevel
level Handler
handler = do
Config
cfg <- GititServerPart Config
getConfig
if AuthenticationLevel
level forall a. Ord a => a -> a -> Bool
<= Config -> AuthenticationLevel
requireAuthentication Config
cfg
then do
Maybe User
mbUser <- GititServerPart (Maybe User)
getLoggedInUser
Request
rq <- forall (m :: * -> *). ServerMonad m => m Request
askRq
let url :: String
url = Request -> String
rqUri Request
rq forall a. [a] -> [a] -> [a]
++ Request -> String
rqQuery Request
rq
case Maybe User
mbUser of
Maybe User
Nothing -> forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect (String
"/_login?" forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
urlEncodeVars [(String
"destination", String
url)]) forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse ()
Just User
u -> if User -> Bool
predicate User
u
then Handler
handler
else forall a. Partial => String -> a
error String
"Not authorized."
else Handler
handler
withUserFromSession :: Handler -> Handler
withUserFromSession :: Handler -> Handler
withUserFromSession Handler
handler = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Maybe SessionKey
mbsk :: Maybe SessionKey) -> do
Maybe SessionData
mbSd <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall (m :: * -> *).
MonadIO m =>
SessionKey -> m (Maybe SessionData)
getSession Maybe SessionKey
mbsk
Config
cfg <- GititServerPart Config
getConfig
Maybe User
mbUser <- case Maybe SessionData
mbSd of
Maybe SessionData
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just SessionData
sd -> do
case Maybe SessionKey
mbsk of
Maybe SessionKey
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just SessionKey
sk ->
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg)
(SessionKey -> Cookie
mkSessionCookie SessionKey
sk)
case SessionData -> Maybe String
sessionUser SessionData
sd of
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just String
user -> String -> GititServerPart (Maybe User)
getUser String
user
let user :: String
user = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" User -> String
uUsername Maybe User
mbUser
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"REMOTE_USER" String
user) Handler
handler
withUserFromHTTPAuth :: Handler -> Handler
withUserFromHTTPAuth :: Handler -> Handler
withUserFromHTTPAuth Handler
handler = do
Request
req <- forall (m :: * -> *). ServerMonad m => m Request
askRq
let user :: String
user = case forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"authorization" Request
req of
Maybe ByteString
Nothing -> String
""
Just ByteString
authHeader -> case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse forall st. GenParser Char st String
pAuthorizationHeader String
"" (ByteString -> String
UTF8.toString ByteString
authHeader) of
Left ParseError
_ -> String
""
Right String
u -> String
u
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"REMOTE_USER" String
user) Handler
handler
getLoggedInUser :: GititServerPart (Maybe User)
getLoggedInUser :: GititServerPart (Maybe User)
getLoggedInUser = do
Request
req <- forall (m :: * -> *). ServerMonad m => m Request
askRq
case forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ByteString -> String
UTF8.toString (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"REMOTE_USER" Request
req) of
String
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
String
u -> do
Maybe User
mbUser <- String -> GititServerPart (Maybe User)
getUser String
u
case Maybe User
mbUser of
Just User
user -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just User
user
Maybe User
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just User{uUsername :: String
uUsername = String
u, uEmail :: String
uEmail = String
"", uPassword :: Password
uPassword = forall a. Partial => a
undefined}
pAuthorizationHeader :: GenParser Char st String
= forall tok st a. GenParser tok st a -> GenParser tok st a
try forall st. GenParser Char st String
pBasicHeader forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall st. GenParser Char st String
pDigestHeader
pDigestHeader :: GenParser Char st String
= do
String
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Digest username=\""
String
result' <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"")
Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
forall (m :: * -> *) a. Monad m => a -> m a
return String
result'
pBasicHeader :: GenParser Char st String
= do
String
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Basic "
String
result' <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
" \t\n")
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
':') forall a b. (a -> b) -> a -> b
$ ByteString -> String
UTF8.toString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decodeLenient forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString String
result'
unlessNoEdit :: Handler
-> Handler
-> Handler
unlessNoEdit :: Handler -> Handler -> Handler
unlessNoEdit Handler
responder Handler
fallback = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
Config
cfg <- GititServerPart Config
getConfig
String
page <- GititServerPart String
getPage
if String
page forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [String]
noEdit Config
cfg
then forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages (String
"Page is locked." forall a. a -> [a] -> [a]
: Params -> [String]
pMessages Params
params) Handler
fallback
else Handler
responder
unlessNoDelete :: Handler
-> Handler
-> Handler
unlessNoDelete :: Handler -> Handler -> Handler
unlessNoDelete Handler
responder Handler
fallback = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Params
params :: Params) -> do
Config
cfg <- GititServerPart Config
getConfig
String
page <- GititServerPart String
getPage
if String
page forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [String]
noDelete Config
cfg
then forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages (String
"Page cannot be deleted." forall a. a -> [a] -> [a]
: Params -> [String]
pMessages Params
params) Handler
fallback
else Handler
responder
getPath :: ServerMonad m => m String
getPath :: forall (m :: * -> *). ServerMonad m => m String
getPath = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. [a] -> [[a]] -> [a]
intercalate String
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [String]
rqPaths) forall (m :: * -> *). ServerMonad m => m Request
askRq
getPage :: GititServerPart String
getPage :: GititServerPart String
getPage = do
Config
conf <- GititServerPart Config
getConfig
String
path' <- forall (m :: * -> *). ServerMonad m => m String
getPath
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path'
then forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> String
frontPage Config
conf)
else if String -> Bool
isPage String
path'
then forall (m :: * -> *) a. Monad m => a -> m a
return String
path'
else forall (m :: * -> *) a. MonadPlus m => m a
mzero
getReferer :: ServerMonad m => m String
getReferer :: forall (m :: * -> *). ServerMonad m => m String
getReferer = do
Request
req <- forall (m :: * -> *). ServerMonad m => m Request
askRq
String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"referer" Request
req of
Just ByteString
r -> case ByteString -> String
UTF8.toString ByteString
r of
String
"" -> String
base'
String
s -> String
s
Maybe ByteString
Nothing -> String
base'
getWikiBase :: ServerMonad m => m String
getWikiBase :: forall (m :: * -> *). ServerMonad m => m String
getWikiBase = do
String
path' <- forall (m :: * -> *). ServerMonad m => m String
getPath
String
uri' <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Partial => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Maybe String
decString Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
rqUri) forall (m :: * -> *). ServerMonad m => m Request
askRq
case String -> String -> Maybe String
calculateWikiBase String
path' String
uri' of
Just String
b -> forall (m :: * -> *) a. Monad m => a -> m a
return String
b
Maybe String
Nothing -> forall a. Partial => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not getWikiBase: (path, uri) = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
path',String
uri')
calculateWikiBase :: String -> String -> Maybe String
calculateWikiBase :: String -> String -> Maybe String
calculateWikiBase String
path' String
uri' =
let revpaths :: [String]
revpaths = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'/' String
path'
revuris :: [String]
revuris = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'/' String
uri'
in if [String]
revpaths forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [String]
revuris
then let revbase :: [String]
revbase = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
revpaths) [String]
revuris
revbase' :: [String]
revbase' = case [String]
revbase of
(String
x:[String]
xs) | String -> Bool
startsWithUnderscore String
x -> [String]
xs
[String]
xs -> [String]
xs
base' :: String
base' = forall a. [a] -> [[a]] -> [a]
intercalate String
"/" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [String]
revbase'
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base' then String
"" else Char
'/' forall a. a -> [a] -> [a]
: String
base'
else forall a. Maybe a
Nothing
startsWithUnderscore :: String -> Bool
startsWithUnderscore :: String -> Bool
startsWithUnderscore (Char
'_':String
_) = Bool
True
startsWithUnderscore String
_ = Bool
False
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn :: forall a. Eq a => a -> [a] -> [[a]]
splitOn a
c [a]
cs =
let ([a]
next, [a]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==a
c) [a]
cs
in case [a]
rest of
[] -> [[a]
next]
(a
_:[a]
rs) -> [a]
next forall a. a -> [a] -> [a]
: forall a. Eq a => a -> [a] -> [[a]]
splitOn a
c [a]
rs
uriPath :: String -> String
uriPath :: String -> String
uriPath = [String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'?')
isPage :: String -> Bool
isPage :: String -> Bool
isPage String
"" = Bool
False
isPage (Char
'_':String
_) = Bool
False
isPage String
s = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"*?") String
s Bool -> Bool -> Bool
&& Bool -> Bool
not (String
".." forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s) Bool -> Bool -> Bool
&& Bool -> Bool
not (String
"/_" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s)
isPageFile :: FilePath -> GititServerPart Bool
isPageFile :: String -> GititServerPart Bool
isPageFile String
f = do
Config
cfg <- GititServerPart Config
getConfig
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String
takeExtension String
f forall a. Eq a => a -> a -> Bool
== String
"." forall a. [a] -> [a] -> [a]
++ (Config -> String
defaultExtension Config
cfg)
isDiscussPage :: String -> Bool
isDiscussPage :: String -> Bool
isDiscussPage (Char
'@':String
xs) = String -> Bool
isPage String
xs
isDiscussPage String
_ = Bool
False
isDiscussPageFile :: FilePath -> GititServerPart Bool
isDiscussPageFile :: String -> GititServerPart Bool
isDiscussPageFile (Char
'@':String
xs) = String -> GititServerPart Bool
isPageFile String
xs
isDiscussPageFile String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isNotDiscussPageFile :: FilePath -> GititServerPart Bool
isNotDiscussPageFile :: String -> GititServerPart Bool
isNotDiscussPageFile (Char
'@':String
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isNotDiscussPageFile String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isSourceCode :: String -> Bool
isSourceCode :: String -> Bool
isSourceCode String
path' =
let langs :: [Syntax]
langs = SyntaxMap -> String -> [Syntax]
syntaxesByFilename SyntaxMap
defaultSyntaxMap forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
path'
ext :: String
ext = String -> String
takeExtension String
path'
in Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Syntax]
langs Bool -> Bool -> Bool
|| String
ext forall a. Eq a => a -> a -> Bool
== String
".svg" Bool -> Bool -> Bool
|| String
ext forall a. Eq a => a -> a -> Bool
== String
".eps")
urlForPage :: String -> String
urlForPage :: String -> String
urlForPage String
page = Char
'/' forall a. a -> [a] -> [a]
: Bool -> (Char -> Bool) -> String -> String
encString Bool
False Char -> Bool
isUnescapedInURI String
page
pathForPage :: String -> String -> FilePath
pathForPage :: String -> String -> String
pathForPage String
page String
ext = String
page String -> String -> String
<.> String
ext
getMimeTypeForExtension :: String -> GititServerPart String
getMimeTypeForExtension :: String -> GititServerPart String
getMimeTypeForExtension String
ext = do
Map String String
mimes <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Config -> Map String String
mimeMap GititServerPart Config
getConfig
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"application/octet-stream"
(forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'.') forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
ext) Map String String
mimes)
validate :: [(Bool, String)]
-> [String]
validate :: [(Bool, String)] -> [String]
validate = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}. [a] -> (Bool, a) -> [a]
go []
where go :: [a] -> (Bool, a) -> [a]
go [a]
errs (Bool
condition, a
msg) = if Bool
condition then a
msgforall a. a -> [a] -> [a]
:[a]
errs else [a]
errs
guardCommand :: String -> GititServerPart ()
guardCommand :: String -> ServerPartT (ReaderT WikiState IO) ()
guardCommand String
command = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \(Command
com :: Command) ->
case Command
com of
Command (Just String
c) | String
c forall a. Eq a => a -> a -> Bool
== String
command -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Command
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
guardPath :: (String -> Bool) -> GititServerPart ()
guardPath :: (String -> Bool) -> ServerPartT (ReaderT WikiState IO) ()
guardPath String -> Bool
pred' = forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq (String -> Bool
pred' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
rqUri)
guardIndex :: GititServerPart ()
guardIndex :: ServerPartT (ReaderT WikiState IO) ()
guardIndex = do
String
base <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
String
uri' <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> String
rqUri forall (m :: * -> *). ServerMonad m => m Request
askRq
let localpath :: String
localpath = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
base) String
uri'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
localpath forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& forall a. Partial => String -> [a] -> a
lastNote String
"guardIndex" String
uri' forall a. Eq a => a -> a -> Bool
== Char
'/')
forall (m :: * -> *) a. MonadPlus m => m a
mzero
guardBareBase :: GititServerPart ()
guardBareBase :: ServerPartT (ReaderT WikiState IO) ()
guardBareBase = do
String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
String
uri' <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> String
rqUri forall (m :: * -> *). ServerMonad m => m Request
askRq
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base') Bool -> Bool -> Bool
&& String
base' forall a. Eq a => a -> a -> Bool
== String
uri')
forall (m :: * -> *) a. MonadPlus m => m a
mzero
withMessages :: ServerMonad m => [String] -> m a -> m a
withMessages :: forall (m :: * -> *) a. ServerMonad m => [String] -> m a -> m a
withMessages [String]
messages m a
handler = do
Request
req <- forall (m :: * -> *). ServerMonad m => m Request
askRq
let inps :: [(String, Input)]
inps = forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
n,Input
_) -> String
n forall a. Eq a => a -> a -> Bool
/= String
"message") forall a b. (a -> b) -> a -> b
$ Request -> [(String, Input)]
rqInputsQuery Request
req
let newInp :: String -> (String, Input)
newInp String
msg = (String
"message", Input {
inputValue :: Either String ByteString
inputValue = forall a b. b -> Either a b
Right
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LazyUTF8.fromString String
msg
, inputFilename :: Maybe String
inputFilename = forall a. Maybe a
Nothing
, inputContentType :: ContentType
inputContentType = ContentType {
ctType :: String
ctType = String
"text"
, ctSubtype :: String
ctSubtype = String
"plain"
, ctParameters :: [(String, String)]
ctParameters = [] }
})
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
rq -> Request
rq{ rqInputsQuery :: [(String, Input)]
rqInputsQuery = forall a b. (a -> b) -> [a] -> [b]
map String -> (String, Input)
newInp [String]
messages forall a. [a] -> [a] -> [a]
++ [(String, Input)]
inps }) m a
handler
filestoreFromConfig :: Config -> FileStore
filestoreFromConfig :: Config -> FileStore
filestoreFromConfig Config
conf =
case Config -> FileStoreType
repositoryType Config
conf of
FileStoreType
Git -> String -> FileStore
gitFileStore forall a b. (a -> b) -> a -> b
$ Config -> String
repositoryPath Config
conf
FileStoreType
Darcs -> String -> FileStore
darcsFileStore forall a b. (a -> b) -> a -> b
$ Config -> String
repositoryPath Config
conf
FileStoreType
Mercurial -> String -> FileStore
mercurialFileStore forall a b. (a -> b) -> a -> b
$ Config -> String
repositoryPath Config
conf
mkSessionCookie :: SessionKey -> Cookie
mkSessionCookie :: SessionKey -> Cookie
mkSessionCookie (SessionKey Integer
key) = String -> String -> Cookie
mkCookie String
"sid" (forall a. Show a => a -> String
show Integer
key)