module WebGear.Core.Handler.Static (
serveDir,
serveFile,
) where
import Control.Arrow ((<<<))
import Control.Exception.Safe (catchIO)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import qualified Network.Mime as Mime
import System.FilePath (joinPath, takeFileName, (</>))
import WebGear.Core.Handler (Handler (..), RoutePath (..), unlinkA)
import WebGear.Core.Request (Request (..))
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Linked (..), Sets)
import WebGear.Core.Trait.Body (Body, setBodyWithoutContentType)
import WebGear.Core.Trait.Header (RequiredHeader, setHeader)
import WebGear.Core.Trait.Status (Status, notFound404, ok200)
import Prelude hiding (readFile)
serveDir ::
( MonadIO m
, Handler h m
, Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response
) =>
FilePath ->
Maybe FilePath ->
h (Linked req Request) Response
serveDir :: forall (m :: * -> *) (h :: * -> * -> *) (req :: [*]).
(MonadIO m, Handler h m,
Sets
h
'[Status, RequiredHeader "Content-Type" MimeType, Body ByteString]
Response) =>
FilePath -> Maybe FilePath -> h (Linked req Request) Response
serveDir FilePath
root Maybe FilePath
index = proc Linked req Request
_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 (Linked ts Response) Response
unlinkA 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 () (Linked '[Status] Response)
notFound404 -< ()
(RoutePath [], Just FilePath
f) -> forall (m :: * -> *) (h :: * -> * -> *).
(MonadIO m, Handler h m,
Sets
h
'[Status, RequiredHeader "Content-Type" MimeType, Body ByteString]
Response) =>
h FilePath Response
serveFile -< FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
f
(RoutePath [Text]
ps, Maybe FilePath
_) -> forall (m :: * -> *) (h :: * -> * -> *).
(MonadIO m, Handler h m,
Sets
h
'[Status, RequiredHeader "Content-Type" MimeType, Body ByteString]
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 ::
( MonadIO m
, Handler h m
, Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response
) =>
h FilePath Response
serveFile :: forall (m :: * -> *) (h :: * -> * -> *).
(MonadIO m, Handler h m,
Sets
h
'[Status, RequiredHeader "Content-Type" MimeType, Body ByteString]
Response) =>
h FilePath Response
serveFile = proc FilePath
file -> do
Maybe ByteString
maybeContents <- h FilePath (Maybe ByteString)
readFile -< FilePath
file
case Maybe ByteString
maybeContents of
Maybe ByteString
Nothing -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA 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 () (Linked '[Status] Response)
notFound404 -< ()
Just ByteString
contents -> do
let 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 :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall (name :: Symbol) val a (h :: * -> * -> *) (res :: [*]).
Set h (Header 'Required 'Strict name val) Response =>
h a (Linked res Response)
-> h (val, a)
(Linked (Header 'Required 'Strict name val : res) Response)
setHeader @"Content-Type" (forall body a (h :: * -> * -> *) (ts :: [*]).
Set h (Body body) Response =>
h a (Linked ts Response)
-> h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType forall (h :: * -> * -> *).
Set h Status Response =>
h () (Linked '[Status] Response)
ok200) -< (MimeType
contentType, (ByteString
contents, ()))
where
readFile :: h FilePath (Maybe ByteString)
readFile = forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM forall a b. (a -> b) -> a -> b
$ \FilePath
f -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile FilePath
f) forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)