> module Frame.Server (
>   server,
>   testServer
> ) where

> import qualified Frame.Router as Router
> import Network.HTTP.Headers
> import Happstack.Server 
> import Happstack.Server.FastCGI (runFastCGIConcurrent, serverPartToCGI) 
> import Control.Monad.Trans
> import Control.Monad.State (StateT)
> import Data.MIME.Types
> import qualified Data.ByteString.Lazy as L
> import qualified Data.ByteString.UTF8 as U

> import Frame.Validation
> import Frame.GUI
> import Frame.Data
> import Frame.Types
> import Frame.Config
> import Frame.Router
> import Frame.Session

> simpleCGI :: (ToMessage a) => ServerPartT IO a -> IO ()
> simpleCGI = runFastCGIConcurrent 10 . serverPartToCGI

> runCGI :: ServerPart Response -> IO ()
> runCGI s = do
>   simpleCGI s

> run :: ServerPart Response -> IO ()
> run s = do
>   simpleHTTP nullConf{ port = 3000 } s

> serverPart :: ([(String, String)] -> String -> String -> Bool -> IO Data) 
>            -> ServerPart Response
> serverPart f = do
>   r <- askRq
>   mid <- getDataFn $ lookCookieValue "framesid"
>   case mid of
>      Nothing   -> do 
>           sid <- liftIO genSessionId 
>           addCookie (3600) (mkCookie "framesid" sid) 
>           routerToResponse f r sid
>      (Just sid) -> do 
>           addCookie (3600) (mkCookie "framesid" sid) 
>           routerToResponse f r sid

> routerToResponse :: ([(String, String)] -> String -> String -> Bool -> IO Data)
>                  -> Request
>                  -> String
>                  -> ServerPart Response
> routerToResponse f r sid = withDataFn lookPairs $ 
>                 \vs -> do d <- liftIO $ f vs (rqURL r) sid $ isAjax r
>                           dataToResponse d r

> dataToResponse :: Data
>                -> Request
>                -> ServerPart Response
> dataToResponse (File bs) r     = return $ detectMime r $ fileResponse bs r
> dataToResponse Error404 r      = notFound $ htmlContent $ toResponse $ "Could not find " ++ rqURL r
> dataToResponse (Redirect u) r  = seeOther u $ toResponse $ "See " ++ u
> dataToResponse (ViewPart ps) r = return $ htmlContent $ toResponse $ concatMap show ps
> dataToResponse (View g) r      = return $ htmlContent $ toResponse $ show g

> htmlContent :: Response -> Response
> htmlContent = setHeader "Content-Type" "text/html"

> fileResponse :: L.ByteString 
>              -> Request 
>              -> Response
> fileResponse bs r = lazyByteStringResponse (mimeType $ rqURL r) bs Nothing 0 $ fromIntegral $ L.length bs

> detectMime :: Request -> Response -> Response
> detectMime r = setHeader "Content-Type" (mimeType $ rqURL r)

> mimeType :: String -> String
> mimeType u = case guessType defaultmtd False u of
>                   (Just t, _)  -> t
>                   (Nothing, _) -> "image/jpeg" 

> isAjax :: Request -> Bool
> isAjax r = case getHeader "X-Requested-With" r of
>                   (Just bs) -> U.toString bs == "XMLHttpRequest"
>                   Nothing   -> False 

> -- | Start a test server
> testServer :: Router     -- ^ The router to run
>            -> Config     -- ^ The configuration
>            -> Validators -- ^ The validators to check fields against
>            -> IO ()      -- ^ The server action
> testServer r c v = do
>     putStr "\nA server is running at http://127.0.0.1:3000/\n"
>     run $ serverPart $ startRouter r c v
>     return ()

> -- | Start Frame using FastCGI
> server :: Router     -- ^ The router to run
>        -> Config     -- ^ The configuration
>        -> Validators -- ^ The validators to check fields against
>        -> IO ()      -- ^ The server action
> server r c v = do
>     runCGI $ serverPart $ startRouter r c v