{-# LANGUAGE OverloadedStrings #-}
module Web.Simple.Static where

import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import Network.Wai
import Network.HTTP.Types
import Network.Mime
import Web.Simple.Controller
import System.Directory
import System.FilePath

serveStatic :: FilePath -> Controller a ()
serveStatic :: FilePath -> Controller a ()
serveStatic baseDir :: FilePath
baseDir = do
  Request
req <- Controller a Request
forall s. Controller s Request
request
  let fp :: FilePath
fp = (FilePath -> FilePath -> FilePath)
-> FilePath -> [FilePath] -> FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FilePath -> FilePath -> FilePath
(</>) FilePath
baseDir ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack ([Text] -> [FilePath]) -> [Text] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req)
  Bool
exists <- IO Bool -> ControllerT a IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ControllerT a IO Bool)
-> IO Bool -> ControllerT a IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fp
  Bool -> Controller a () -> Controller a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (Controller a () -> Controller a ())
-> Controller a () -> Controller a ()
forall a b. (a -> b) -> a -> b
$ do
    Response -> Controller a ()
forall s a. Response -> Controller s a
respond (Response -> Controller a ()) -> Response -> Controller a ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
responseFile Status
status200
      [(HeaderName
hContentType, Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
fp)]
      FilePath
fp Maybe FilePart
forall a. Maybe a
Nothing
  Bool -> Controller a () -> Controller a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeExtension FilePath
fp) (Controller a () -> Controller a ())
-> Controller a () -> Controller a ()
forall a b. (a -> b) -> a -> b
$ do
    let fpIdx :: FilePath
fpIdx = FilePath
fp FilePath -> FilePath -> FilePath
</> "index.html"
    Bool
existsIdx <- IO Bool -> ControllerT a IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ControllerT a IO Bool)
-> IO Bool -> ControllerT a IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fpIdx
    Bool -> Controller a () -> Controller a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
existsIdx (Controller a () -> Controller a ())
-> Controller a () -> Controller a ()
forall a b. (a -> b) -> a -> b
$ do
      Response -> Controller a ()
forall s a. Response -> Controller s a
respond (Response -> Controller a ()) -> Response -> Controller a ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
responseFile Status
status200
        [(HeaderName
hContentType, "text/html")]
        FilePath
fpIdx Maybe FilePart
forall a. Maybe a
Nothing