Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 63 lines (53 sloc) 2.468 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
{-# 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.Parts (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 = liftM (setHeader "Cache-Control" "max-age=21600")

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 $ case addrs of -- head addrs
                                                                     [] -> error "lookupIPAddr, no addrs"
                                                                     (x:_) -> x
getHost :: ServerMonad m => m (Maybe String)
getHost = liftM (maybe Nothing (Just . U.toString)) $ getHeaderM "Host"
Something went wrong with that request. Please try again.