/
Controller.hs
84 lines (69 loc) · 3.06 KB
/
Controller.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
module Yanagi.Controller (run) where
import Control.Concurrent
import qualified Network.FastCGI as CGI
-- import Monad (liftM, liftM3)
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Lazy.Char8 as BS
import Codec.Binary.UTF8.String (decodeString)
import Yanagi.Types
import qualified Yanagi.View as View
-- Framework Main --
run :: AppConfig -> IO ()
run = CGI.runFastCGIConcurrent' forkIO 100 . router
router :: AppConfig -> CGI.CGI CGI.CGIResult
router cfg = CGI.setHeader "Content-type" (contentType cfg)
>> makeRequests >>= CGI.liftIO . assignEpView cfg >>= CGI.output
assignEpView :: AppConfig -> (Request, Req) -> IO String
assignEpView cfg (req,inp) = do
newCtx <- (findAct cfg name) defaultContext
let tName = templateName newCtx
tmpl <- templateData cfg tName
return $ View.parseTemplate tName tmpl $ results newCtx
where name :: ActName
name = findActName cfg req
defaultContext = Context { request = req
, inputs = inp
, pathInfo = pathInfoList req
, results = []
, templateName = actToTmpl name
, outputType = defaultOutputType cfg
}
findAct :: AppConfig -> ActName -> Act
findAct cfg name =
fromMaybe (defaultAct cfg) $ lookup (unActName name) $ entryPoints cfg
findActName :: AppConfig -> Request -> ActName
findActName cfg req = pathInfoToActName (pathInfoFilter cfg)
(defaultActName cfg) (pathInfoStr req)
makeRequests :: (CGI.MonadCGI m) => m (Request, Req)
makeRequests = do
r <- CGI.requestMethod
p <- CGI.pathInfo
let pl = split '/' (case p of
('/':ps) -> ps
ps -> ps)
sv <- CGI.serverName
rq <- CGI.getInputs
sc <- CGI.scriptName
return $ (Request { requestMethod = r
, pathInfoStr = p
, pathInfoList = pl
, serverName = sv
, scriptName = sc
} , decode rq)
where split sep xs = case (break (== sep) xs) of
(ys, []) -> [ys]
(ys, (sep':zs)) -> [ys] ++ split sep' zs
decode req = ((map (\(n,v) -> (n, decodeString v))) req)
templateData :: AppConfig -> TmplName -> IO String
templateData c n = catch (BS.readFile (fullTemplate c n) >>= return . BS.unpack)
(\_ -> notFoundData c)
fullTemplate :: AppConfig -> TmplName -> String
fullTemplate c n = templateDir c ++ unTmplName n ++ templateExtension c
notFoundData :: AppConfig -> IO String
notFoundData cfg = catch (BS.readFile (notFound cfg) >>= return . BS.unpack )
(\_ -> return $ "Please save "
++ unTmplName (notFoundTemplate cfg)
++ " for not found error.")
notFound :: AppConfig -> String
notFound cfg = templateDir cfg
++ unTmplName (notFoundTemplate cfg)