network-minihttp-0.2: examples/test.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Monad.State.Strict

import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import qualified Data.Map as Map

import Network.MiniHTTP.Server
import Network.MiniHTTP.Marshal
import Network.MiniHTTP.HTTPConnection
import Network.MiniHTTP.Session
import qualified Network.MiniHTTP.OpenID as OpenID
import qualified Network.MiniHTTP.Session as Session
import qualified Network.MiniHTTP.URL as URL
import qualified Text.CTemplate as T

import qualified OpenSSL as SSL

handleFromTemplate :: T.Dictionary -> WebMonad ()
handleFromTemplate tmpl = do
  Just r <- lift $ T.expand T.DontStrip tmpl
  source <- lift $ bsSource r
  setReply 200
  s <- get
  put $ s { wsSource = Just source }
  setHeader $ \h -> h { httpContentLength = Just $ fromIntegral $ B.length r }

index :: WebMonad ()
index = do
  session <- getSession
  handleFromTemplate $ T.Dictionary "example.tmpl" [("SESSION", T.StringV $ show session)]
  setHeader $ \h -> h { httpOtherHeaders = Map.fromList [("Cache-Control", "private")] }

setSession :: WebMonad ()
setSession = do
  postValues <- getPOST 1024
  setReply 301
  case Map.lookup "name" postValues of
       Nothing -> return ()
       Just name -> addSession "name" name
  setHeader $ \h -> h { httpLocation = Just "/" }

openIDLogin :: WebMonad ()
openIDLogin = do
  postValues <- getPOST 1024
  id <- Map.lookup "id" postValues
  let Just uri = URL.parse id
  discovery <- liftIO $ OpenID.discover uri
  (handle, _) <- liftIO $ OpenID.associate discovery
  setReply 302
  let url = OpenID.checkID OpenID.CheckIDSetup uri discovery handle "http://localhost.com/openidreturn" Nothing
  setHeader (\h -> h { httpLocation = Just $ URL.serialise url })

openIDReturn :: WebMonad ()
openIDReturn = do
  args <- getGET
  r <- liftIO $ OpenID.processCheckIDReply args
  case r of
       Left error -> errorPage error
       Right id -> do
         setReply 301
         addSession "openid" id
         setHeader $ \h -> h { httpLocation = Just "/" }

handleFile :: WebMonad ()
handleFile = do
  handleFromFilesystem "css/"
  handleConditionalRequest
  handleRangeRequests
  handleHandleToSource
  handleDecoration

main' :: IO ()
main' = serveHTTP 4112 $ dispatchOnURL
  [ (Exact "", index), (Exact "setsession", setSession)
  , (Exact "openidlogin", openIDLogin), (Exact "openidreturn", openIDReturn)
  , (Prefix "", handleFile)]

main :: IO ()
main = SSL.withOpenSSL main'