{- |
 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 :: 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)

-- | 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 :: 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)