gitit-0.5.1: Gitit/Server.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-
Copyright (C) 2008 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
-}

{- Re-exports HAppS functions needed by gitit, including 
   replacements for HAppS functions that don't handle UTF-8 properly,
   new functions for setting headers and zipping contents and for looking up IP
   addresses, and a fix for broken HAppS cookie parsing.
-}

module Gitit.Server
          ( look
          , lookPairs
          , lookRead
          , mkCookie
          , filterIf
          , gzipBinary
          , acceptsZip
          , withExpiresHeaders
          , setContentType
          , setFilename
          , lookupIPAddr
          , readMimeTypesFile
          , cookieFixer
          -- re-exported HAppS functions
          , ok
          , toResponse
          , Response(..)
          , Method(..)
          , Request(..)
          , Input(..)
          , HeaderPair(..)
          , Web
          , ServerPart
          , FromData(..)
          , waitForTermination
          , Conf(..)
          , simpleHTTP
          , fileServe
          , dir
          , multi
          , seeOther
          , withData
          , withRequest
          , anyRequest
          , noHandle
          , uriRest
          , lookInput
          , addCookie
          , lookCookieValue
          , readCookieValue
          )
where
import HAppS.Server hiding (look, lookRead, lookPairs, mkCookie, getCookies)
import qualified HAppS.Server (mkCookie)
import HAppS.Server.Cookie (Cookie(..))
import Network.Socket (getAddrInfo, defaultHints, addrAddress)
import System.IO (stderr, hPutStrLn)
import Text.Pandoc.CharacterReferences (decodeCharacterReferences)
import Control.Monad (liftM)
import Control.Monad.Reader
import Data.DateTime
import Data.ByteString.Lazy.UTF8 (toString)
import Codec.Binary.UTF8.String (encodeString)
import qualified Data.ByteString.Char8 as C
import Data.Char (chr, toLower)
import Data.List ((\\))
import Data.Maybe
import qualified Data.Map as M
import Codec.Compression.GZip (compress)
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
-- Hide Parsec's definitions of some Applicative functions.
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>), token)

-- Contents of an HTML text area or text field generated by Text.XHtml
-- will often contain decimal character references.  We want to convert these
-- to regular unicode characters.  We also need to use toString to
-- convert from UTF-8, since HAppS doesn't do this.

look :: String -> RqData String
look = liftM (decodeCharacterReferences . toString) . lookBS

lookPairs :: RqData [(String,String)]
lookPairs = asks fst >>= return . map (\(n,vbs)->(n,toString $ inputValue vbs))

lookRead :: Read a => String -> RqData a
lookRead = liftM read . look

mkCookie :: String -> String -> Cookie
mkCookie name = HAppS.Server.mkCookie name . encodeString

-- Functions for zipping responses and setting headers.

filterIf :: (Request -> Bool) -> (Response -> Response) -> ServerPart Response -> ServerPart Response
filterIf test filt sp =
  let handler = unServerPartT sp
  in  withRequest $ \req ->
      if test req
         then liftM filt $ handler req
         else handler req

gzipBinary :: Response -> Response
gzipBinary r@(Response {rsBody = b}) =  setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b}

acceptsZip :: Request -> Bool
acceptsZip req = isJust $ M.lookup (C.pack "accept-encoding") (rqHeaders req)

getCacheTime :: IO (Maybe DateTime)
getCacheTime = liftM (Just . addMinutes 360) $ getCurrentTime

withExpiresHeaders :: ServerPart Response -> ServerPart Response
withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp]

setContentType :: String -> Response -> Response
setContentType = setHeader "Content-Type"

setFilename :: String -> Response -> Response
setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\""

-- IP lookup

lookupIPAddr :: String -> IO (Maybe String)
lookupIPAddr hostname = do
  addrs <- getAddrInfo (Just defaultHints) (Just hostname) Nothing
  if null addrs
     then return Nothing
     else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ head addrs


-- mime types

-- | Read a file associating mime types with extensions, and return a
-- map from extensions to types. Each line of the file consists of a
-- mime type, followed by space, followed by a list of zero or more
-- extensions, separated by spaces. Example: text/plain txt text
readMimeTypesFile :: FilePath -> IO (M.Map String String)
readMimeTypesFile f = catch (readFile f >>= return . foldr go M.empty . map words . lines) $
                            handleMimeTypesFileNotFound
     where go []     m = m  -- skip blank lines
           go (x:xs) m = foldr (\ext m' -> M.insert ext x m') m xs
           handleMimeTypesFileNotFound e = do
             hPutStrLn stderr $ "Could not read mime types file: " ++ f
             hPutStrLn stderr $ show e
             hPutStrLn stderr $ "Using defaults instead."
             return mimeTypes

----- the following code is from the HAppSHelpers package, 0.10,
----- (C) 2008 Thomas Hartman.
----- Needed until HAppS Server cookie parsing is fixed.

instance Applicative (GenParser s a) where
    pure = return
    (<*>) = ap

instance Alternative (GenParser s a) where
    empty = mzero
    (<|>) = mplus

parseCookiesM :: (Monad m) => String -> m [Cookie]
parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str

cookiesParser :: GenParser Char st [Cookie]
cookiesParser = av_pairs
    where -- Parsers based on RFC 2109
          av_pairs      = (:) <$> av_pair <*> many (char ';' *>  av_pair)
          av_pair       = cookie <$> attr <*> option "" (char '=' *> value)
          attr          = spaces *> token
          value         = word
          word          = incomp_token <|> quoted_string

          -- Parsers based on RFC 2068
          token         = many1 $ oneOf ((chars \\ ctl) \\ tspecials)
          quoted_string = char '"' *> many (oneOf qdtext) <* char '"'

          -- Custom parser, incompatible with RFC 2068, but very  forgiving ;)
          incomp_token  = many1 $ oneOf ((chars \\ ctl) \\ "\";")

          -- Primitives from RFC 2068
          tspecials     = "()<>@,;:\\\"/[]?={} \t"
          ctl           = map chr (127:[0..31])
          chars         = map chr [0..127]
          octet         = map chr [0..255]
          text          = octet \\ ctl
          qdtext        = text \\ "\""

cookie :: String -> String -> Cookie
cookie key value = Cookie "" "" "" (low key) value

cookieFixer :: ServerPartT m a -> ServerPartT m a
cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } )
    where
      fixedCookies request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]

-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from
-- the most specific to the least specific. Multiple cookies with the same
-- name are allowed to exist.
getCookies :: Monad m => C.ByteString -> m [Cookie]
getCookies header | C.null header = return []
                  | otherwise     = parseCookiesM (C.unpack header)

low :: String -> String
low = map toLower