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