Happstack.hs

module Hack.Frontend.Happstack where

import Data.Foldable (toList)
import Data.Maybe
import Hack (http, pathInfo, scriptName, queryString, hackInput, serverName, serverPort, Application)
import Happstack.Server
import Happstack.Server.HTTP.Types (Request (..), Version (Version))
import Happstack.Server.SURI (parse)
import Network.URI (unEscapeString)
import qualified Data.ByteString.Char8 as S
import qualified Hack
import qualified Hack as Hack
import qualified Happstack.Server as H


serverPartToApp :: (ToMessage b) => ServerPartT IO b -> Application
serverPartToApp = convert . processRequest

convert :: (Request -> IO Response) -> Application
convert f = \env -> do
  let rq = toHappstackRequest env
  rs <- f rq
  let r = toHackResponse rs
  return r

toHackResponse :: Response -> Hack.Response
toHackResponse r = Hack.Response
  {
    Hack.body = rsBody r
  , Hack.status = rsCode r
  , Hack.headers = map convertHeader $ toList (rsHeaders r)
  }

-- | Sets all the headers coming from Happstack
convertHeader :: HeaderPair -> (String, String)
convertHeader (HeaderPair k v) = (S.unpack k, S.unpack (last v))

-- | Converts one request into another
toHappstackRequest :: Hack.Env -> Request
toHappstackRequest env =
  tmpRequest
    { rqInputs = queryInput uri ++ bodyInput tmpRequest }
  where
    uri = fromJust $ parse $ concat $ map (\f -> f env) 
      [ serverName
      , const ":"
      , show . serverPort
      , scriptName
      , pathInfo
      , add_q . queryString
      ]
    tmpRequest = 
      Request { rqMethod  = convertRequestMethod $ Hack.requestMethod env
              , rqPaths   = split '/' $ unescape $ pathInfo env
              , rqUri	    = unescape $ scriptName env ++ pathInfo env
              , rqQuery   = unescape $ add_q $ queryString env
              , rqInputs  = []
              , rqCookies = readCookies $ http env
              , rqVersion = Version 1 1
              , rqHeaders = mkHeaders $ http env
              , rqBody    = Body $ hackInput env
              , rqPeer    = (serverName env, serverPort env)
              }
    unescape = unEscapeString
  
    convertRequestMethod Hack.OPTIONS     =     OPTIONS
    convertRequestMethod Hack.GET         =     GET
    convertRequestMethod Hack.HEAD        =     HEAD
    convertRequestMethod Hack.POST        =     POST
    convertRequestMethod Hack.PUT         =     PUT
    convertRequestMethod Hack.DELETE      =     DELETE
    convertRequestMethod Hack.TRACE       =     TRACE
    convertRequestMethod Hack.CONNECT     =     CONNECT
    
    
    readCookies = map cookieWithName 
      . either (const []) id . parseCookies . fromMaybe "" . lookup "Cookie"
      
    add_q [] = []
    add_q x = '?' : x

cookieWithName :: H.Cookie -> (String, H.Cookie)
cookieWithName x = (H.cookieName x, x)


-- | Transforms a ServerPartT into a function. This is a copy of simpleHTTP'
processRequest :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response
processRequest hs req =  (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))
    where
        standardNotFound = H.setHeader "Content-Type" "text/html" $ toResponse "Not found"


-- | Splits a list by character, the resulting lists don't have the character in them.
split :: Char -> String -> [String]
split c cs = filter (not.null) $ worker [] cs
    where worker acc [] = [reverse acc]
          worker acc (c':cs') | c==c' = reverse acc:worker [] cs'
          worker acc (c':cs') = worker (c':acc) cs'