    {-# 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.Reader
    import Data.ByteString.UTF8 as U hiding (lines)

    withExpiresHeaders :: ServerMonad m => m Response -> m Response
    withExpiresHeaders :: 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 "Cache-Control" "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 "Content-Type"

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

    -- IP lookup

    lookupIPAddr :: String -> IO (Maybe String)
    lookupIPAddr :: String -> IO (Maybe String)
    lookupIPAddr hostname :: String
    hostname = do
      [AddrInfo]
    addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [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 [AddrInfo] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [AddrInfo]
    addrs
         then Maybe String -> IO (Maybe String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing
         else Maybe String -> IO (Maybe String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe String -> IO (Maybe String))
    -> Maybe String -> IO (Maybe String)
    forall a b. (a -> b) -> a -> b
    $ String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=':') (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ SockAddr -> String
    forall a. Show a => a -> String
    show (SockAddr -> String) -> SockAddr -> String
    forall a b. (a -> b) -> a -> b
    $ AddrInfo -> SockAddr
    addrAddress (AddrInfo -> SockAddr) -> AddrInfo -> SockAddr
    forall a b. (a -> b) -> a -> b
    $ case [AddrInfo]
    addrs of -- head addrs
                                                                         [] -> String -> AddrInfo
    forall a. HasCallStack => String -> a
    error "lookupIPAddr, no addrs"
                                                                         (x :: AddrInfo
    x:_) -> AddrInfo
    x
    getHost :: ServerMonad m => m (Maybe String)
    getHost :: 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 "Host"