{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}
module Yesod.EmbeddedStatic.Css.Util where

import Control.Applicative
import Control.Monad (void, foldM)
import Data.Hashable (Hashable)
import Data.Monoid
import Network.Mime (MimeType, defaultMimeLookup)
import Text.CSS.Parse (parseBlocks)
import Language.Haskell.TH (litE, stringL)
import Text.CSS.Render (renderBlocks)
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic (pathToName)
import Data.Default (def)
import System.FilePath ((</>), takeFileName, takeDirectory, dropExtension)

import qualified Blaze.ByteString.Builder as B
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Attoparsec.Text as P
import qualified Data.Attoparsec.ByteString.Lazy as PBL
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64 as B64
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL

-------------------------------------------------------------------------------
-- Loading CSS
-------------------------------------------------------------------------------

-- | In the parsed CSS, this will be an image reference that we want to replace.
-- the contents will be the filepath.
newtype UrlReference = UrlReference T.Text
    deriving (Show, Eq, Hashable, Ord)

type EithUrl = (T.Text, Either T.Text UrlReference)

-- | The parsed CSS
type Css = [(T.Text, [EithUrl])]

-- | Parse the filename out of url('filename')
parseUrl :: P.Parser T.Text
parseUrl = do
    P.skipSpace
    void $ P.string "url('"
    P.takeTill (== '\'')

checkForUrl :: T.Text -> T.Text -> EithUrl
checkForUrl n@("background-image") v = parseBackgroundImage n v
checkForUrl n@("src") v = parseBackgroundImage n v
checkForUrl n v = (n, Left v)

-- | Check if a given CSS attribute is a background image referencing a local file
checkForImage :: T.Text -> T.Text -> EithUrl
checkForImage n@("background-image") v = parseBackgroundImage n v
checkForImage n v = (n, Left v)

parseBackgroundImage :: T.Text -> T.Text -> EithUrl
parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of
    Left _ -> Left v -- Can't parse url
    Right url -> -- maybe we should find a uri parser
        if any (`T.isPrefixOf` url) ["http://", "https://", "/"]
            then Left v
            else Right $ UrlReference url)

parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
parseCssWith urlParser contents =
    let mparsed = parseBlocks contents in
    case mparsed of
        Left err -> Left err
        Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]

parseCssUrls :: T.Text -> Either String Css
parseCssUrls = parseCssWith checkForUrl

parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
parseCssFileWith urlParser fp = do
    mparsed <- parseCssWith urlParser <$> T.readFile fp
    case mparsed of
        Left err -> fail $ "Unable to parse " ++ fp ++ ": " ++ err
        Right css -> return css

parseCssFileUrls :: FilePath -> IO Css
parseCssFileUrls = parseCssFileWith checkForUrl

renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text
renderCssWith urlRenderer css =
    TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css]
  where
    render (n, Left b) = (n, b)
    render (n, Right f) = (n, urlRenderer f)

-- | Load an image map from the images in the CSS
loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)
loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css]
    where
        load imap (Left _) = return imap
        load imap (Right f) | f `M.member` imap = return imap
        load imap (Right f@(UrlReference path)) = do
            img <- loadImage (dir </> T.unpack path)
            return $ maybe imap (\i -> M.insert f i imap) img


-- | If you tack on additional CSS post-processing filters, they use this as an argument.
data CssGeneration = CssGeneration {
                       cssContent :: BL.ByteString
                     , cssStaticLocation :: Location
                     , cssFileLocation :: FilePath
                     }

mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration
mkCssGeneration loc file content =
    CssGeneration { cssContent = content
                  , cssStaticLocation = loc
                  , cssFileLocation = file
                  }

cssProductionFilter ::
       (FilePath ->  IO BL.ByteString) -- ^ a filter to be run on production
     -> Location -- ^ The location the CSS file should appear in the static subsite
     -> FilePath -- ^ Path to the CSS file.
     -> Entry
cssProductionFilter prodFilter loc file =
    def { ebHaskellName = Just $ pathToName loc
        , ebLocation = loc
        , ebMimeType = "text/css"
        , ebProductionContent = prodFilter file
        , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL file)) |]
        , ebDevelExtraFiles = Nothing
        }

cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry
cssProductionImageFilter prodFilter loc file =
  (cssProductionFilter prodFilter loc file)
    { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL file)) |]
    , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |]
    }

-------------------------------------------------------------------------------
-- Helpers for the generators
-------------------------------------------------------------------------------

-- For development, all we need to do is update the background-image url to base64 encode it.
-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse
-- using css-parse.  Instead we write a simple custom parser.

parseBackground :: Location -> FilePath -> PBL.Parser B.Builder
parseBackground loc file = do
    void $ PBL.string "background-image"
    s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
    void $ PBL.word8 58 -- colon
    s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
    void $ PBL.string "url('"
    url <- PBL.takeWhile (/= 39) -- single quote
    void $ PBL.string "')"

    let b64 = B64.encode $ T.encodeUtf8 (T.pack $ takeDirectory file) <> url
        newUrl = B.fromString (takeFileName loc) <> B.fromString "/" <> B.fromByteString b64

    return $ B.fromByteString "background-image"
          <> B.fromByteString s1
          <> B.fromByteString ":"
          <> B.fromByteString s2
          <> B.fromByteString "url('"
          <> newUrl
          <> B.fromByteString "')"

parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder
parseDev loc file b = do
    b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8)
    (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b')

develPassThrough :: Location -> FilePath -> IO BL.ByteString
develPassThrough _ = BL.readFile

-- | Create the CSS during development
develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
develBgImgB64 loc file = do
    ct <- BL.readFile file
    case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of
        Left err -> error err
        Right b -> return $ B.toLazyByteString b

-- | Serve the extra image files during development
develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
develExtraFiles loc parts =
    case reverse parts of
        (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do
            let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ T.pack $ dropExtension $ T.unpack file
            ct <- BL.readFile $ T.unpack file'
            return $ Just (defaultMimeLookup file', ct)
        _ -> return Nothing