> 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
>
> testServer :: Router
> -> Config
> -> Validators
> -> IO ()
> 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 ()
>
> server :: Router
> -> Config
> -> Validators
> -> IO ()
> server r c v = do
> runCGI $ serverPart $ startRouter r c v