0 | module TyTTP.HTTP.Routing
  1 |
  2 | import Data.Mime.Apache
  3 | import Data.String
  4 |
  5 | import TyTTP
  6 | import TyTTP.HTTP.Protocol
  7 |
  8 | namespace Method
  9 |
 10 |   methodRouter : Alternative m
 11 |     => Method 
 12 |     -> (
 13 |       Context Method u v h1 s h2 a b
 14 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 15 |     )
 16 |     -> Context Method u v h1 s h2 a b
 17 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 18 |   methodRouter m handler ctx =
 19 |     if ctx.request.method == m 
 20 |     then handler ctx
 21 |     else empty
 22 |
 23 |   export
 24 |   options : Alternative m
 25 |     => (
 26 |       Context Method u v h1 s h2 a b
 27 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 28 |     )
 29 |     -> Context Method u v h1 s h2 a b
 30 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 31 |   options = methodRouter OPTIONS
 32 |
 33 |   export
 34 |   get : Alternative m
 35 |     => (
 36 |       Context Method u v h1 s h2 a b
 37 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 38 |     )
 39 |     -> Context Method u v h1 s h2 a b
 40 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 41 |   get = methodRouter GET
 42 |
 43 |   export
 44 |   head : Alternative m
 45 |     => (
 46 |       Context Method u v h1 s h2 a b
 47 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 48 |     )
 49 |     -> Context Method u v h1 s h2 a b
 50 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 51 |   head = methodRouter HEAD
 52 |
 53 |   export
 54 |   post : Alternative m
 55 |     => (
 56 |       Context Method u v h1 s h2 a b
 57 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 58 |     )
 59 |     -> Context Method u v h1 s h2 a b
 60 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 61 |   post = methodRouter POST
 62 |
 63 |   export
 64 |   put : Alternative m
 65 |     => (
 66 |       Context Method u v h1 s h2 a b
 67 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 68 |     )
 69 |     -> Context Method u v h1 s h2 a b
 70 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 71 |   put = methodRouter PUT
 72 |
 73 |   export
 74 |   delete : Alternative m
 75 |     => (
 76 |       Context Method u v h1 s h2 a b
 77 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 78 |     )
 79 |     -> Context Method u v h1 s h2 a b
 80 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 81 |   delete = methodRouter DELETE
 82 |
 83 |   export
 84 |   trace : Alternative m
 85 |     => (
 86 |       Context Method u v h1 s h2 a b
 87 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 88 |     )
 89 |     -> Context Method u v h1 s h2 a b
 90 |     -> m $ Context me' p' v' h1' s' h2' a' b'
 91 |   trace = methodRouter TRACE
 92 |
 93 |   export
 94 |   connect : Alternative m
 95 |     => (
 96 |       Context Method u v h1 s h2 a b
 97 |       -> m $ Context me' p' v' h1' s' h2' a' b'
 98 |     )
 99 |     -> Context Method u v h1 s h2 a b
100 |     -> m $ Context me' p' v' h1' s' h2' a' b'
101 |   connect = methodRouter CONNECT
102 |
103 |   export
104 |   other : Alternative m
105 |     => String
106 |     -> (
107 |       Context Method u v h1 s h2 a b
108 |       -> m $ Context me' p' v' h1' s' h2' a' b'
109 |     )
110 |     -> Context Method u v h1 s h2 a b
111 |     -> m $ Context me' p' v' h1' s' h2' a' b'
112 |   other str = methodRouter (OtherMethod str)
113 |
114 | namespace ContentType
115 |
116 |   stringMatchesMime : Mime -> String -> Bool
117 |   stringMatchesMime mime candidate =
118 |     let mimeString = show mime
119 |     in isPrefixOf mimeString $ toLower candidate
120 |
121 |   export
122 |   contentType : Alternative m
123 |     => HasContentType h1
124 |     => Mime
125 |     -> (
126 |       Context me u v h1 s h2 a b
127 |       -> m $ Context me' p' v' h1' s' h2' a' b'
128 |     )
129 |     -> Context me u v h1 s h2 a b
130 |     -> m $ Context me' p' v' h1' s' h2' a' b'
131 |   contentType mime handler ctx =
132 |     case stringMatchesMime mime <$> getContentType ctx.request.headers of
133 |       Just True => handler ctx
134 |       _ => empty
135 |
136 |   export
137 |   json : Alternative m
138 |     => HasContentType h1
139 |     => (
140 |       Context me u v h1 s h2 a b
141 |       -> m $ Context me' p' v' h1 s' h2' a' b'
142 |     )
143 |     -> Context me u v h1 s h2 a b
144 |     -> m $ Context me' p' v' h1 s' h2' a' b'
145 |   json = contentType APPLICATION_JSON
146 |
147 |   export
148 |   text : Alternative m
149 |     => HasContentType h1
150 |     => (
151 |       Context me u v h1 s h2 a b
152 |       -> m $ Context me' p' v' h1 s' h2' a' b'
153 |     )
154 |     -> Context me u v h1 s h2 a b
155 |     -> m $ Context me' p' v' h1 s' h2' a' b'
156 |   text = contentType TEXT_PLAIN
157 |
158 |   export
159 |   binary : Alternative m
160 |     => HasContentType h1
161 |     => (
162 |       Context me u v h1 s h2 a b
163 |       -> m $ Context me' p' v' h1 s' h2' a' b'
164 |     )
165 |     -> Context me u v h1 s h2 a b
166 |     -> m $ Context me' p' v' h1 s' h2' a' b'
167 |   binary = contentType APPLICATION_OCTET_STREAM
168 |