0 | module TyTTP.Adapter.Node.Static
 1 |
 2 | import Data.Buffer
 3 | import Data.Maybe
 4 | import Data.Mime.Apache
 5 | import Data.List
 6 | import Control.Monad.Either
 7 | import Node.Error
 8 | import Node.FS
 9 | import TyTTP.Adapter.Node.Error
10 | import TyTTP.Adapter.Node.HTTP
11 | import TyTTP.HTTP
12 | import TyTTP.URL
13 | import TyTTP.URL.Path
14 |
15 | public export
16 | Resource : Type
17 | Resource = String
18 |
19 | public export
20 | data FileServingError : Type where
21 |   StatError : Error e => e -> FileServingError
22 |   NotAFile : Resource -> FileServingError
23 |
24 | public export
25 | StaticRequest : Type -> Type
26 | StaticRequest url = Context Method url Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) ()
27 |
28 | public export
29 | StaticResponse : Type -> Type
30 | StaticResponse url = Context Method url Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) (Publisher IO Error Buffer)
31 |
32 | record StaticSuccesResult where
33 |   constructor MkStaticSuccessResult
34 |   size : Int
35 |   stream : Publisher IO Error Buffer
36 |   mime : Mime
37 |
38 | export
39 | hStatic : HasIO io
40 |   => (folder : String)
41 |   -> (returnError : FileServingError
42 |     -> StaticRequest (URL a Path s)
43 |     -> io $ StaticResponse (URL a Path s)
44 |   )
45 |   -> (ctx : StaticRequest (URL a Path s))
46 |   -> io $ StaticResponse (URL a Path s)
47 | hStatic folder returnError ctx = eitherT (flip returnError ctx) returnSuccess $ do
48 |     let resource = ctx.request.url.path.rest
49 |         file = "\{folder}\{resource}"
50 |
51 |     fs <- FS.require
52 |     Right stats <- fs.statSync StatsInt file
53 |       | Left e => throwError $ case e.code of
54 |          SystemError ENOENT => NotAFile resource
55 |          _ => StatError e
56 |
57 |     True <- pure $ stats.isFile
58 |       | _ => throwError $ NotAFile resource
59 |
60 |     False <- pure $ stats.isDirectory
61 |       | _ => throwError $ NotAFile resource
62 |
63 |     readStream <- fs.createReadStream file
64 |
65 |     pure $ MkStaticSuccessResult
66 |             { size = Stats.size stats
67 |             , stream = MkPublisher $ \s => do
68 |                 readStream.onData  s.onNext
69 |                 readStream.onEnd   $ s.onSucceded ()
70 |                 readStream.onError s.onFailed
71 |             , mime = mimeOf file
72 |             }
73 |
74 |   where
75 |     returnSuccess : StaticSuccesResult -> io $ StaticResponse (URL a Path s)
76 |     returnSuccess result = do
77 |       let hs = [ ("Content-Length", show $ result.size)
78 |                , ("Content-Type", show $ result.mime)
79 |                ]
80 |       pure $ { response.status := OK
81 |              , response.headers := hs
82 |              , response.body := result.stream } ctx 
83 |
84 |     extensionOf' : (ext: List Char) -> (file: List Char) -> (dot: Bool) -> Maybe (List Char)
85 |     extensionOf' ext ('.' :: xs) _ = extensionOf' xs xs True
86 |     extensionOf' ext (x :: xs) dot = extensionOf' ext xs dot
87 |     extensionOf' ext [] True = Just ext
88 |     extensionOf' ext [] False = Nothing
89 |
90 |     extensionOf : String -> Maybe String
91 |     extensionOf file = let l = unpack file in
92 |                            map pack $ extensionOf' l l False
93 |
94 |     mimeOf : String -> Mime
95 |     mimeOf file =
96 |       fromMaybe TEXT_PLAIN $
97 |         flip lookup extensions =<< extensionOf file
98 |
99 |