module WebGear.Core.Handler.Static (
serveDir,
serveFile,
) where
import Control.Arrow ((<<<))
import qualified Data.Text as Text
import qualified Network.Mime as Mime
import System.FilePath (joinPath, takeFileName, (</>))
import WebGear.Core.Handler (Handler (..), RoutePath (..), unwitnessA, (>->))
import WebGear.Core.Request (Request (..))
import WebGear.Core.Response (Response, ResponseBody (..))
import WebGear.Core.Trait (Sets, With)
import WebGear.Core.Trait.Body (UnknownContentBody, setBodyWithoutContentType)
import WebGear.Core.Trait.Header (RequiredResponseHeader, setHeader)
import WebGear.Core.Trait.Status (Status, notFound404, ok200)
import Prelude hiding (readFile)
serveDir ::
( Handler h m
, Sets
h
[ Status
, RequiredResponseHeader "Content-Type" Mime.MimeType
, UnknownContentBody
]
Response
) =>
FilePath ->
Maybe FilePath ->
h (Request `With` ts) Response
serveDir :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(Handler h m,
Sets
h
'[Status, RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody]
Response) =>
FilePath -> Maybe FilePath -> h (With Request ts) Response
serveDir FilePath
root Maybe FilePath
index = proc With Request ts
_request -> forall (h :: * -> * -> *) (m :: * -> *) a.
Handler h m =>
h RoutePath a -> h () a
consumeRoute h RoutePath Response
go -< ()
where
go :: h RoutePath Response
go = proc RoutePath
path -> do
case (RoutePath
path, Maybe FilePath
index) of
(RoutePath [], Maybe FilePath
Nothing) -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall (h :: * -> * -> *).
Set h Status Response =>
h () (With Response '[Status])
notFound404 -< ()
(RoutePath [], Just FilePath
f) -> forall (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
Sets
h
'[Status, RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody]
Response) =>
h FilePath Response
serveFile -< FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
f
(RoutePath [Text]
ps, Maybe FilePath
_) -> forall (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
Sets
h
'[Status, RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody]
Response) =>
h FilePath Response
serveFile -< FilePath
root FilePath -> FilePath -> FilePath
</> [FilePath] -> FilePath
joinPath (Text -> FilePath
Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ps)
serveFile ::
( Handler h m
, Sets
h
[ Status
, RequiredResponseHeader "Content-Type" Mime.MimeType
, UnknownContentBody
]
Response
) =>
h FilePath Response
serveFile :: forall (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
Sets
h
'[Status, RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody]
Response) =>
h FilePath Response
serveFile = proc FilePath
file -> do
let contents :: ResponseBody
contents = FilePath -> Maybe FilePart -> ResponseBody
ResponseBodyFile FilePath
file forall a. Maybe a
Nothing
contentType :: MimeType
contentType = Text -> MimeType
Mime.defaultMimeLookup forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
file
(forall (h :: * -> * -> *).
Set h Status Response =>
h () (With Response '[Status])
ok200 -< ())
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[Status]
resp -> forall (h :: * -> * -> *) (ts :: [*]).
Set h UnknownContentBody Response =>
h (With Response ts, ResponseBody)
(With Response (UnknownContentBody : ts))
setBodyWithoutContentType -< (With Response '[Status]
resp, ResponseBody
contents))
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[UnknownContentBody, Status]
resp -> forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Required name val) Response =>
h (With Response ts, val)
(With Response (ResponseHeader 'Required name val : ts))
setHeader @"Content-Type" -< (With Response '[UnknownContentBody, Status]
resp, MimeType
contentType))
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
Response
'[RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody, Status]
resp -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA -< With
Response
'[RequiredResponseHeader "Content-Type" MimeType,
UnknownContentBody, Status]
resp)