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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Program.Mighty.Route (
-- * Paring a routing file
parseRoute,
-- * Types
RouteDB,
Route (..),
Block (..),
Src,
Dst,
Domain,
Port,
-- * RouteDBRef
RouteDBRef,
newRouteDBRef,
readRouteDBRef,
writeRouteDBRef,
) where
import Control.Monad
import Data.ByteString
import qualified Data.ByteString.Char8 as BS
import Data.IORef
#ifdef DHALL
import GHC.Natural (Natural)
#endif
import Network.Wai.Application.Classic
import Text.Parsec
import Text.Parsec.ByteString.Lazy
import Program.Mighty.Parser
----------------------------------------------------------------
-- | A logical path specified in URL.
type Src = Path
-- | A physical path in a file system.
type Dst = Path
type Domain = ByteString
#ifdef DHALL
type Port = Natural
#else
type Port = Int
#endif
data Block = Block [Domain] [Route] deriving (Eq, Show)
data Route
= RouteFile Src Dst
| RouteRedirect Src Dst
| RouteCGI Src Dst
| RouteRevProxy Src Dst Domain Port
deriving (Eq, Show)
type RouteDB = [Block]
----------------------------------------------------------------
-- | Parsing a route file.
parseRoute
:: FilePath
-> Domain
-- ^ A default domain, typically \"localhost\"
-> Port
-- ^ A default port, typically 80.
-> IO RouteDB
parseRoute file ddom dport = parseFile (routeDB ddom dport) file
routeDB :: Domain -> Port -> Parser RouteDB
routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof
block :: Domain -> Port -> Parser Block
block ddom dport = Block <$> cdomains <*> many croute
where
cdomains = domains <* commentLines
croute = route ddom dport <* commentLines
domains :: Parser [Domain]
domains = open *> doms <* close <* trailing
where
open = () <$ char '[' *> spcs
close = () <$ char ']' *> spcs
doms = (domain `sepBy1` sep) <* spcs
domain = BS.pack <$> many1 (noneOf "[], \t\n")
sep = () <$ spcs1
data Op = OpFile | OpCGI | OpRevProxy | OpRedirect
route :: Domain -> Port -> Parser Route
route ddom dport = do
s <- src
o <- op
case o of
OpFile -> RouteFile s <$> dst <* trailing
OpRedirect -> RouteRedirect s <$> dst' <* trailing
OpCGI -> RouteCGI s <$> dst <* trailing
OpRevProxy -> do
(dom, prt, d) <- domPortDst ddom dport
return $ RouteRevProxy s d dom prt
where
src = path
dst = path
dst' = path'
op0 =
OpFile <$ string "->"
<|> OpRedirect <$ string "<<"
<|> OpCGI <$ string "=>"
<|> OpRevProxy <$ string ">>"
op = op0 <* spcs
path :: Parser Path
path = do
c <- char '/'
BS.pack . (c :) <$> many (noneOf "[], \t\n") <* spcs
path' :: Parser Path
path' = BS.pack <$> many (noneOf "[], \t\n") <* spcs
-- [host1][:port2]/path2
domPortDst :: Domain -> Port -> Parser (Domain, Port, Dst)
domPortDst ddom dport =
(ddom,,) <$> port <*> path
<|> try ((,,) <$> domain <*> port <*> path)
<|> (,dport,) <$> domain <*> path
where
domain = BS.pack <$> many1 (noneOf ":/[], \t\n")
port = do
void $ char ':'
read <$> many1 (oneOf ['0' .. '9'])
----------------------------------------------------------------
newtype RouteDBRef = RouteDBRef (IORef RouteDB)
newRouteDBRef :: RouteDB -> IO RouteDBRef
newRouteDBRef rout = RouteDBRef <$> newIORef rout
readRouteDBRef :: RouteDBRef -> IO RouteDB
readRouteDBRef (RouteDBRef ref) = readIORef ref
writeRouteDBRef :: RouteDBRef -> RouteDB -> IO ()
writeRouteDBRef (RouteDBRef ref) rout = writeIORef ref rout
|
