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

-- | Serve files under the specified directory.
serveDir ::
  ( Handler h m
  , Sets
      h
      [ Status
      , RequiredResponseHeader "Content-Type" Mime.MimeType
      , UnknownContentBody
      ]
      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 (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)

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