{- |
 Handlers for serving static resources
-}
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)

-- | Serve files under the specified directory.
serveDir ::
  ( MonadIO m
  , Handler h m
  , Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response
  ) =>
  -- | The directory to serve
  FilePath ->
  -- | Optional index filename for the root directory. A 404 Not Found
  -- response will be returned for requests to the root path if this
  -- is set to @Nothing@.
  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)

-- | Serve a file specified by the input filepath.
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)