ParseRequest.hs

module HAppS.Helpers.ParseRequest where

import HAppS.Server.HTTP.Types
import Text.StringTemplate.Helpers
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Data.String.Utils (split)
{- |
Try to return the "home page" of a happs server, basically, the host plus an optional path.
The "smart" part is trying to deal sanely with HAppS serving behind apache mod rewrite,
a common situation for me at least
because it lets you have multiple happs servers listening on different ports, all
looking to the casual user like they are being served on port 80, and also unblocked by firewalls.
-}
smartAppUrl :: String -> Request -> String
smartAppUrl path' rq =
  let forwardinghost = getHeaderVal "x-forwarded-server" rq
      vanillahost = getHeaderVal "host" rq
      apphost = case forwardinghost of
        Right h -> h
        Left _ -> case vanillahost of
          Right h -> h
          Left _ -> "getAppUrlCantDetermineHost" --ugly way to propogate error!
      -- trim starting slash if necessary
      path = case path' of
               "" -> ""
               '/':cs -> cs
               x -> x
  in render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$"



{- | 
getHost = getHeaderVal \"host\" 

returns host with port numbers, if anything other than default 80
-}
getHost :: Request -> Either String String
getHost = getHeaderVal "host" 

{- |
retrieve val of header for key supplied, or an error message if the key isn't found
-}
getHeaderVal :: String -> Request -> Either String String
getHeaderVal headerKey rq = maybe (Left $ "getHeaderVal, bad headerKey: " ++ headerKey)
                                         ( Right . B.unpack . head . hValue )
                                         ( M.lookup ( B.pack headerKey ) . rqHeaders $ rq )

{- | 
host with port number stripped out, if any. 

Useful, for example, for getting the right address to ssh to. 
-}
getDomain :: Request -> Either String String
getDomain rq = do
  h <- getHost rq
  let parts = split ":" h
  case parts of
        [d] -> Right d
        [d,p] -> Right d
        xs -> Left $ "getDomain, bad domain: " ++ h