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