a teate of happstack

Happstack 是一个比较成熟的haskell的web框架. 其教程也简明易懂, 我用起来感觉很顺手.
目前用到的功能都在Haskell内, 整个应用都是编译的, 只要系统架构相同, 部署起来只要拷贝可执行程序即可, 不用安装Haskell的编译器.
为了方便用浏览器观看本地的Html文档,提供统一的入口, 编写了一个小小的Haskell服务器程序,使用了Happstack 和 blaze-html
配置文件:
配置文件的位置是/etc/fser.conf, 在配置文件中编写所有本地需要映射的目录,以及用来从服务器访问的url路径.格式如下:

haskell-doc=/var/hs-doc
share-files=/home/wuxb/share

启动服务器的时候会自动加载路径配置, 这样访问本地的8000端口就可以看到所有文件夹的入口了,按照规则,一切错误的路径也都会指向入口索引,不会出现没有意义的页面.
编译代码前要cabal install happstack, 我是在ghc-7.2.1下开发的,对于以前的ghc版本应该也没有问题.
多说无益,相关文档写的非常清楚,搜索happstack/blaze-html/monad等关键字就可以找到关于本代码的资料了.


服务器程序的代码:servdir.hs  编译选项:-threaded, 不加也可以,就是会并发时有性能影响而已.

{-# LANGUAGE OverloadedStrings #-}
import Data.Maybe
import Happstack.Server
import Control.Monad (msum)
import Text.Blaze
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
type PathConf = (String, String) -- ^ url, filepath
main :: IO ()
main = (getConf . lines) `fmap` readFile "/etc/fser.conf" >>= servFileWith
appTemplate :: String -> H.Html -> H.Html
appTemplate title body = H.html $ do
   H.head $ do
     H.title (H.toHtml title)
     H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html;charset=uft-8"
   H.body body
servFileWith :: [PathConf] -> IO ()
servFileWith pcs = do simpleHTTP nullConf $ msum $ withConf ++ [indexPage]
  where
   withConf = map (\(u, p) -> dir u $ serveDirectory EnableBrowsing [] p) pcs
   indexPage = ok $ toResponse $ appTemplate "INDEX" $ sequence_ $ map toA pcs
   toA (u,_) = H.h1 $ H.a ! A.href (toValue u) $ (H.toHtml u) >> H.br
getConf :: [String] -> [PathConf]
getConf ss = catMaybes $ map getConf1 ss
   where
     getConf1 s = case break (== '=') s of
     (u,(_:p)) -> Just (u,p)
     _ -> Nothing


启动脚本的代码: servdir.server, 可以放在/etc/init.d里
#!/usr/local/bin/runghc
import System.Environment
import System.Cmd

cmdmap =
  [ ("stop", "killall servdir")
  , ("start", "nohup /root/servdir &>/dev/null &")
  , ("restart", "killall servdir; nohup /root/servdir &>/dev/null &")
  ]

main :: IO ()
main = do
  args <- getArgs
  this <- getProgName
  case args of
    []    -> putStrLn $ "usage: " ++ this ++ " [start|stop|restart]"
    (cmdname:_) -> case lookup cmdname cmdmap of
        Just cmd -> system cmd >> return ()
        Nothing -> putStrLn $ "usage: " ++ this ++ " [start|stop|restart]"