{-# LANGUAGE CPP #-}
{-# 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 Happstack functions needed by gitit, including
   replacements for Happstack functions that don't handle UTF-8 properly, and
   new functions for setting headers and zipping contents and for looking up IP
   addresses.
-}

module Network.Gitit.Server
          ( module Happstack.Server
          , withExpiresHeaders
          , setContentType
          , setFilename
          , lookupIPAddr
          , getHost
          , compressedResponseFilter
          )
where
import Happstack.Server
import Happstack.Server.Compression (compressedResponseFilter)
import Network.Socket (getAddrInfo, defaultHints, addrAddress)
import Control.Monad (liftM)
import Data.ByteString.UTF8 as U hiding (lines)

withExpiresHeaders :: ServerMonad m => m Response -> m Response
withExpiresHeaders :: forall (m :: * -> *). ServerMonad m => m Response -> m Response
withExpiresHeaders = (Response -> Response) -> m Response -> m Response
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Cache-Control" String
"max-age=21600")

setContentType :: String -> Response -> Response
setContentType :: String -> Response -> Response
setContentType = String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Type"

setFilename :: String -> Response -> Response
setFilename :: String -> Response -> Response
setFilename = String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Disposition" (String -> Response -> Response)
-> (String -> String) -> String -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \String
fname -> String
"attachment; filename=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

-- IP lookup

lookupIPAddr :: String -> IO (Maybe String)
lookupIPAddr :: String -> IO (Maybe String)
lookupIPAddr String
hostname = do
  addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) (String -> Maybe String
forall a. a -> Maybe a
Just String
hostname) Maybe String
forall a. Maybe a
Nothing
  if null addrs
     then return Nothing
     else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ case addrs of -- head addrs
                                                                     [] -> String -> AddrInfo
forall a. HasCallStack => String -> a
error String
"lookupIPAddr, no addrs"
                                                                     (AddrInfo
x:[AddrInfo]
_) -> AddrInfo
x
getHost :: ServerMonad m => m (Maybe String)
getHost :: forall (m :: * -> *). ServerMonad m => m (Maybe String)
getHost = (Maybe ByteString -> Maybe String)
-> m (Maybe ByteString) -> m (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Maybe String
-> (ByteString -> Maybe String) -> Maybe ByteString -> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (ByteString -> String) -> ByteString -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
U.toString)) (m (Maybe ByteString) -> m (Maybe String))
-> m (Maybe ByteString) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> m (Maybe ByteString)
forall (m :: * -> *).
ServerMonad m =>
String -> m (Maybe ByteString)
getHeaderM String
"Host"