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 :: FilePath -> Maybe FilePath -> h (Linked req Request) Response
serveDir FilePath
root Maybe FilePath
index = proc Linked req Request
_request -> h RoutePath Response -> h () Response
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) -> h (Linked '[Status] Response) Response
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA h (Linked '[Status] Response) Response
-> h () (Linked '[Status] Response) -> h () Response
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< h () (Linked '[Status] Response)
forall (h :: * -> * -> *).
Set h Status Response =>
h () (Linked '[Status] Response)
notFound404 -< ()
(RoutePath [], Just FilePath
f) -> h FilePath Response
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
_) -> h FilePath Response
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 (Text -> FilePath) -> [Text] -> [FilePath]
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 :: 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 -> h (Linked '[Status] Response) Response
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA h (Linked '[Status] Response) Response
-> h () (Linked '[Status] Response) -> h () Response
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< h () (Linked '[Status] Response)
forall (h :: * -> * -> *).
Set h Status Response =>
h () (Linked '[Status] Response)
notFound404 -< ()
Just ByteString
contents -> do
let contentType :: MimeType
contentType = Text -> MimeType
Mime.defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
file
h (Linked
'[RequiredHeader "Content-Type" MimeType, Body ByteString, Status]
Response)
Response
forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA h (Linked
'[RequiredHeader "Content-Type" MimeType, Body ByteString, Status]
Response)
Response
-> h (MimeType, (ByteString, ()))
(Linked
'[RequiredHeader "Content-Type" MimeType, Body ByteString, Status]
Response)
-> h (MimeType, (ByteString, ())) Response
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< h (ByteString, ()) (Linked '[Body ByteString, Status] Response)
-> h (MimeType, (ByteString, ()))
(Linked
'[RequiredHeader "Content-Type" MimeType, Body ByteString, Status]
Response)
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" (h () (Linked '[Status] Response)
-> h (ByteString, ()) (Linked '[Body ByteString, Status] Response)
forall body a (h :: * -> * -> *) (ts :: [*]).
Set h (Body body) Response =>
h a (Linked ts Response)
-> h (body, a) (Linked (Body body : ts) Response)
setBodyWithoutContentType h () (Linked '[Status] Response)
forall (h :: * -> * -> *).
Set h Status Response =>
h () (Linked '[Status] Response)
ok200) -< (MimeType
contentType, (ByteString
contents, ()))
where
readFile :: h FilePath (Maybe ByteString)
readFile = (FilePath -> m (Maybe ByteString)) -> h FilePath (Maybe ByteString)
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM ((FilePath -> m (Maybe ByteString))
-> h FilePath (Maybe ByteString))
-> (FilePath -> m (Maybe ByteString))
-> h FilePath (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
LBS.readFile FilePath
f) IO (Maybe ByteString)
-> (IOException -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` IO (Maybe ByteString) -> IOException -> IO (Maybe ByteString)
forall a b. a -> b -> a
const (Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing)