module Clckwrks.Media.PreProcess where
import Control.Monad.Trans
import Control.Applicative
import Clckwrks (ClckT, ClckState)
import Clckwrks.Media.URL
import Clckwrks.Media.Types (MediumId(..))
import Clckwrks.Monad (transform, segments)
import Data.Attoparsec.Text.Lazy (Parser, Result(..), char, choice, decimal, parse, skipMany, space, asciiCI, skipMany)
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as B
import Text.Blaze.Html ((!), toValue)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Web.Routes (showURL)
parseAttr :: Text -> Parser ()
parseAttr name =
do skipMany space
asciiCI name
skipMany space
char '='
skipMany space
width :: Parser H.Attribute
width =
A.width . H.toValue <$> (parseAttr "width" *> (decimal :: Parser Integer))
height :: Parser H.Attribute
height =
A.height . H.toValue <$> (parseAttr "height" *> (decimal :: Parser Integer))
parseCmd :: Parser (MediumId, [H.Attribute])
parseCmd =
(,) <$> (parseAttr "id" *> (MediumId <$> decimal))
<*> (many $ choice [ width, height ])
mediaCmd :: (Monad m) =>
(MediaURL -> [(Text, Maybe Text)] -> Text)
-> TL.Text
-> ClckT url m TL.Text
mediaCmd mediaShowURL txt =
case parse (segments "media" parseCmd) txt of
(Fail _ _ e) -> return (TL.pack e)
(Done _ segments) ->
do b <- transform (applyCmd mediaShowURL) segments
return $ B.toLazyText b
applyCmd mediaShowURL (mid, attrs) =
do let u = toValue $ mediaShowURL (GetMedium mid) []
return $ B.fromLazyText $ renderHtml $ foldr (\attr tag -> tag ! attr) H.img (A.src u : attrs)