content: {-# LANGUAGE ScopedTypeVariables #-}
  {-
  Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>
  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
  -}
  
  {- | Useful functions for defining wiki handlers.
  -}
  
  module Network.Gitit.Framework (
                                 -- * Combinators for dealing with users
                                   withUserFromSession
                                 , withUserFromHTTPAuth
                                 , authenticateUserThat
                                 , authenticate
                                 , getLoggedInUser
                                 -- * Combinators to exclude certain actions
                                 , unlessNoEdit
                                 , unlessNoDelete
                                 -- * Guards for routing
                                 , guardCommand
                                 , guardPath
                                 , guardIndex
                                 , guardBareBase
                                 -- * Functions to get info from the request
                                 , getPath
                                 , getPage
                                 , getReferer
                                 , getWikiBase
                                 , uriPath
                                 -- * Useful predicates
                                 , isPage
                                 , isPageFile
                                 , isDiscussPage
                                 , isDiscussPageFile
                                 , isNotDiscussPageFile
                                 , isSourceCode
                                 -- * Combinators that change the request locally
                                 , withMessages
                                 -- * Miscellaneous
                                 , 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)
  
  -- | Require a logged in user if the authentication level demands it.
  -- Run the handler if a user is logged in, otherwise redirect
  -- to login page.
  authenticate :: AuthenticationLevel -> Handler -> Handler
  authenticate = authenticateUserThat (const True)
  
  
  -- | Like 'authenticate', but with a predicate that the user must satisfy.
  authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler
  authenticateUserThat predicate level handler = do
    cfg <- getConfig
    if level <= requireAuthentication cfg
       then do
         mbUser <- getLoggedInUser
         rq <- askRq
         let url = rqUri rq ++ rqQuery rq
         case mbUser of
              Nothing   -> tempRedirect ("/_login?" ++ urlEncodeVars [("destination", url)]) $ toResponse ()
              Just u    -> if predicate u
                              then handler
                              else error "Not authorized."
       else handler
  
  -- | Run the handler after setting @REMOTE_USER@ with the user from
  -- the session.
  withUserFromSession :: Handler -> Handler
  withUserFromSession handler = withData $ \(mbsk :: Maybe SessionKey) -> do
    mbSd <- maybe (return Nothing) getSession mbsk
    cfg <- getConfig
    mbUser <- case mbSd of
              Nothing    -> return Nothing
              Just sd    -> do
                case mbsk of
                  Nothing -> return ()
                  Just sk ->
                    addCookie (MaxAge $ sessionTimeout cfg) -- refresh timeout
                              (mkSessionCookie sk)
                case sessionUser sd of
                  Nothing -> return Nothing
                  Just user -> getUser user
    let user = maybe "" uUsername mbUser
    localRq (setHeader "REMOTE_USER" user) handler
  
  -- | Run the handler after setting @REMOTE_USER@ from the "authorization"
  -- header.  Works with simple HTTP authentication or digest authentication.
  withUserFromHTTPAuth :: Handler -> Handler
  withUserFromHTTPAuth handler = do
    req <- askRq
    let user = case getHeader "authorization" req of
                Nothing         -> ""
                Just authHeader -> case parse pAuthorizationHeader "" (UTF8.toString authHeader) of
                                    Left _  -> ""
                                    Right u -> u
    localRq (setHeader "REMOTE_USER" user) handler
  
  -- | Returns @Just@ logged in user or @Nothing@.
  getLoggedInUser :: GititServerPart (Maybe User)
  getLoggedInUser = do
    req <- askRq
    case maybe "" UTF8.toString (getHeader "REMOTE_USER" req) of
          "" -> return Nothing
          u  -> do
            mbUser <- getUser u
            case mbUser of
                 Just user -> return $ Just user
                 Nothing   -> return $ Just User{uUsername = u, uEmail = "", uPassword = undefined}
  
  pAuthorizationHeader :: GenParser Char st String
  pAuthorizationHeader = try pBasicHeader <|> pDigestHeader
  
  pDigestHeader :: GenParser Char st String
  pDigestHeader = do
    _ <- string "Digest username=\""
    result' <- many (noneOf "\"")
    _ <- char '"'
    return result'
  
  pBasicHeader :: GenParser Char st String
  pBasicHeader = do
    _ <- string "Basic "
    result' <- many (noneOf " \t\n")
    return $ takeWhile (/=':') $ UTF8.toString
           $ decodeLenient $ UTF8.fromString result'
  
  -- | @unlessNoEdit responder fallback@ runs @responder@ unless the
  -- page has been designated not editable in configuration; in that
  -- case, runs @fallback@.
  unlessNoEdit :: Handler
               -> Handler
               -> Handler
  unlessNoEdit responder fallback = withData $ \(params :: Params) -> do
    cfg <- getConfig
    page <- getPage
    if page `elem` noEdit cfg
       then withMessages ("Page is locked." : pMessages params) fallback
       else responder
  
  -- | @unlessNoDelete responder fallback@ runs @responder@ unless the
  -- page has been designated not deletable in configuration; in that
  -- case, runs @fallback@.
  unlessNoDelete :: Handler
                 -> Handler
                 -> Handler
  unlessNoDelete responder fallback = withData $ \(params :: Params) -> do
    cfg <- getConfig
    page <- getPage
    if page `elem` noDelete cfg
       then withMessages ("Page cannot be deleted." : pMessages params) fallback
       else responder
  
  -- | Returns the current path (subtracting initial commands like @\/_edit@).
  getPath :: ServerMonad m => m String
  getPath = liftM (intercalate "/" . rqPaths) askRq
  
  -- | Returns the current page name (derived from the path).
  getPage :: GititServerPart String
  getPage = do
    conf <- getConfig
    path' <- getPath
    if null path'
       then return (frontPage conf)
       else if isPage path'
               then return path'
               else mzero  -- fail if not valid page name
  
  -- | Returns the contents of the "referer" header.
  getReferer :: ServerMonad m => m String
  getReferer = do
    req <- askRq
    base' <- getWikiBase
    return $ case getHeader "referer" req of
                   Just r  -> case UTF8.toString r of
                                   ""  -> base'
                                   s   -> s
                   Nothing -> base'
  
  -- | Returns the base URL of the wiki in the happstack server.
  -- So, if the wiki handlers are behind a @dir 'foo'@, getWikiBase will
  -- return @\/foo/@.  getWikiBase doesn't know anything about HTTP
  -- proxies, so if you use proxies to map a gitit wiki to @\/foo/@,
  -- you'll still need to follow the instructions in README.
  getWikiBase :: ServerMonad m => m String
  getWikiBase = do
    path' <- getPath
    uri' <- liftM (fromJust . decString True . rqUri) askRq
    case calculateWikiBase path' uri' of
         Just b    -> return b
         Nothing   -> error $ "Could not getWikiBase: (path, uri) = " ++ show (path',uri')
  
  -- | The pure core of 'getWikiBase'.
  calculateWikiBase :: String -> String -> Maybe String
  calculateWikiBase path' uri' =
    let revpaths = reverse . filter (not . null) $ splitOn '/' path'
        revuris  = reverse . filter (not . null) $ splitOn '/' uri'
    in  if revpaths `isPrefixOf` revuris
           then let revbase = drop (length revpaths) revuris
                    -- a path like _feed is not part of the base...
                    revbase' = case revbase of
                               (x:xs) | startsWithUnderscore x -> xs
                               xs                              -> xs
                    base'    = intercalate "/" $ reverse revbase'
                in  Just $ if null base' then "" else '/' : base'
            else Nothing
  
  startsWithUnderscore :: String -> Bool
  startsWithUnderscore ('_':_) = True
  startsWithUnderscore _ = False
  
  splitOn :: Eq a => a -> [a] -> [[a]]
  splitOn c cs =
    let (next, rest) = break (==c) cs
    in case rest of
           []     -> [next]
           (_:rs) -> next : splitOn c rs
  
  -- | Returns path portion of URI, without initial @\/@.
  -- Consecutive spaces are collapsed.  We don't want to distinguish
  -- @Hi There@ and @Hi  There@.
  uriPath :: String -> String
  uriPath = unwords . words . drop 1 . takeWhile (/='?')
  
  isPage :: String -> Bool
  isPage "" = False
  isPage ('_':_) = False
  isPage s = all (`notElem` "*?") s && not (".." `isInfixOf` s) && not ("/_" `isInfixOf` s)
  -- for now, we disallow @*@ and @?@ in page names, because git filestore
  -- does not deal with them properly, and darcs filestore disallows them.
  
  isPageFile :: FilePath -> GititServerPart Bool
  isPageFile f = do
    cfg <- getConfig
    return $ takeExtension f == "." ++ (defaultExtension cfg)
  
  isDiscussPage :: String -> Bool
  isDiscussPage ('@':xs) = isPage xs
  isDiscussPage _ = False
  
  isDiscussPageFile :: FilePath -> GititServerPart Bool
  isDiscussPageFile ('@':xs) = isPageFile xs
  isDiscussPageFile _ = return False
  
  isNotDiscussPageFile :: FilePath -> GititServerPart Bool
  isNotDiscussPageFile ('@':_) = return False
  isNotDiscussPageFile _ = return True
  
  isSourceCode :: String -> Bool
  isSourceCode path' =
    let langs = syntaxesByFilename defaultSyntaxMap $ takeFileName path'
        ext = takeExtension path'
    in  not (null langs || ext == ".svg" || ext == ".eps")
                           -- allow svg or eps to be served as image
  
  -- | Returns encoded URL path for the page with the given name, relative to
  -- the wiki base.
  urlForPage :: String -> String
  urlForPage page = '/' : encString False isUnescapedInURI page
  
  -- | Returns the filestore path of the file containing the page's source.
  pathForPage :: String -> String -> FilePath
  pathForPage page ext = page <.> ext
  
  -- | Retrieves a mime type based on file extension.
  getMimeTypeForExtension :: String -> GititServerPart String
  getMimeTypeForExtension ext = do
    mimes <- liftM mimeMap getConfig
    return $ fromMaybe "application/octet-stream"
      (M.lookup (dropWhile (== '.') $ map toLower ext) mimes)
  
  -- | Simple helper for validation of forms.
  validate :: [(Bool, String)]   -- ^ list of conditions and error messages
           -> [String]           -- ^ list of error messages
  validate = foldl go []
     where go errs (condition, msg) = if condition then msg:errs else errs
  
  guardCommand :: String -> GititServerPart ()
  guardCommand command = withData $ \(com :: Command) ->
    case com of
         Command (Just c) | c == command -> return ()
         _                               -> mzero
  
  guardPath :: (String -> Bool) -> GititServerPart ()
  guardPath pred' = guardRq (pred' . rqUri)
  
  -- | Succeeds if path is an index path:  e.g. @\/foo\/bar/@.
  guardIndex :: GititServerPart ()
  guardIndex = do
    base <- getWikiBase
    uri' <- liftM rqUri askRq
    let localpath = drop (length base) uri'
    unless (length localpath > 1 && lastNote "guardIndex" uri' == '/')
      mzero
  
  -- Guard against a path like @\/wiki@ when the wiki is being
  -- served at @\/wiki@.
  guardBareBase :: GititServerPart ()
  guardBareBase = do
    base' <- getWikiBase
    uri' <- liftM rqUri askRq
    unless (not (null base') && base' == uri')
      mzero
  
  -- | Runs a server monad in a local context after setting
  -- the "message" request header.
  withMessages :: ServerMonad m => [String] -> m a -> m a
  withMessages messages handler = do
    req <- askRq
    let inps = filter (\(n,_) -> n /= "message") $ rqInputsQuery req
    let newInp msg = ("message", Input {
                                inputValue = Right
                                           $ LazyUTF8.fromString msg
                              , inputFilename = Nothing
                              , inputContentType = ContentType {
                                      ctType = "text"
                                    , ctSubtype = "plain"
                                    , ctParameters = [] }
                              })
    localRq (\rq -> rq{ rqInputsQuery = map newInp messages ++ inps }) handler
  
  -- | Returns a filestore object derived from the
  -- repository path and filestore type specified in configuration.
  filestoreFromConfig :: Config -> FileStore
  filestoreFromConfig conf =
    case repositoryType conf of
           Git       -> gitFileStore       $ repositoryPath conf
           Darcs     -> darcsFileStore     $ repositoryPath conf
           Mercurial -> mercurialFileStore $ repositoryPath conf
  
  -- Create a cookie with the session key.
  mkSessionCookie :: SessionKey -> Cookie
  mkSessionCookie (SessionKey key) = mkCookie "sid" (show key)
  