{-# LANGUAGE EmptyDataDecls , GADTs , MultiParamTypeClasses , OverlappingInstances , ScopedTypeVariables , TemplateHaskell , TupleSections , TypeFamilies #-} module Rest.Gen.Docs ( DocsContext (..) , cdiv , cls , mkAllResources , mkSingleResource , resourcesInfo , row , subResourcesInfo , writeDocs ) where import Prelude hiding (div, head, id, id, span, (.)) import qualified Prelude as P import Control.Category ((.)) import Data.Foldable (forM_) import Data.Function (on) import Data.Hashable (hash) import Data.List hiding (head, span) import Data.String import System.Directory import System.FilePath import Text.Blaze.Html import Text.Blaze.Html5 hiding (map, meta, style) import Text.Blaze.Html5.Attributes hiding (method, span, title) import Text.Blaze.Html.Renderer.String import Text.StringTemplate import qualified Data.Label.Total as L import Rest.Api (Router, Version) import Rest.Gen.Base import Rest.Gen.Utils -- | Information about the context in which a resource is contained data DocsContext = DocsContext { rootUrl :: String , contextVersion :: Version , templates :: String } deriving (Eq, Show) writeDocs :: DocsContext -> Router m s -> String -> IO () writeDocs context router loc = do createDirectoryIfMissing True loc let tree = apiSubtrees router mkAllResources context tree >>= writeFile (loc "index.html") mapM_ (writeSingleResource context loc) $ allSubResources tree writeSingleResource :: DocsContext -> String -> ApiResource -> IO () writeSingleResource ctx loc r = do let dr = loc intercalate "/" (resId r) createDirectoryIfMissing True dr mkSingleResource ctx r >>= writeFile (dr "index.html") mkAllResources :: DocsContext -> ApiResource -> IO String mkAllResources ctx tree = do tmpls <- directoryGroup (templates ctx) tmpl <- maybe (putStrLn "Couldn't find template api-docs-all" >> return (newSTMP "")) return $ getStringTemplate "api-docs-all" tmpls return $ render $ setManyAttrib [ ("listing" , map (renderHtml . (\v -> resourceLinkAnchor v (resourceDisp v))) . sort . allSubResourceIds $ tree) ] $ setManyAttrib [ ("resources" , renderHtml $ subResourcesInfo ctx tree ) , ("version" , show $ contextVersion ctx ) , ("static" , rootUrl ctx ) ] tmpl mkSingleResource :: DocsContext -> ApiResource -> IO String mkSingleResource ctx tree = do tmpls <- directoryGroup (templates ctx) tmpl <- maybe (putStrLn "Couldn't find template api-docs-resource" >> return (newSTMP "")) return $ getStringTemplate "api-docs-resource" tmpls return $ render $ setManyAttrib [ ("subresources", map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (resourceDisp v))) $ allResourceIds tree) , ("resource" , resId tree) , ("parents" , map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (toHtml $ last v))) $ tail $ inits (resId tree)) , ("identifiers" , map renderHtml $ resourceIdentifiers (resLink tree) (resIdents tree)) ] $ setManyAttrib [ ("name" , resName tree) , ("urls" , renderHtml $ resourceTable tree) , ("description" , resDescription tree) , ("version" , show $ contextVersion ctx) , ("static" , rootUrl ctx ) ] tmpl -- | Helper functions for generating HTML cls :: String -> Attribute cls = class_ . toValue cdiv :: String -> Html -> Html cdiv s = div ! cls s row :: Html -> Html row = cdiv "row" -- | Recursively generate information for a resource structure resourcesInfo :: DocsContext -> ApiResource -> Html resourcesInfo ctx = foldTree $ (\it -> sequence_ . (resourceInfo ctx it :) ) subResourcesInfo :: DocsContext -> ApiResource -> Html subResourcesInfo ctx = foldTreeChildren sequence_ $ (\it -> sequence_ . (resourceInfo ctx it :) ) -- | Generate information for one resource resourceInfo :: DocsContext -> ApiResource -> Html resourceInfo ctx it = section $ do resourceAnchor (resId it) row $ cdiv "span16 page-header resource-title" $ h1 $ resourceLinkRemote (rootUrl ctx) (resId it) $ resourceDisp (resId it) row $ do cdiv "span10" $ do h2 $ toHtml "Description" p $ toHtml $ resDescription it cdiv "span6" $ do h2 $ toHtml "Identifiers" p $ sequence_ $ intersperse br $ resourceIdentifiers (resLink it) (resIdents it) br resourceTable it resourceIdentifiers :: Link -> [Link] -> [Html] resourceIdentifiers lnk lnks = case lnks of [] -> [toHtml "No identifiers"] ls -> map (linkHtml . (lnk ++)) $ ls resourceTable :: ApiResource -> Html resourceTable it = let urlInfo = groupByFirst . concatMap (\ai -> map (,itemInfo ai) $ flattenLast $ itemLink ai) $ resItems it in table ! cls "bordered-table resource-table" $ do thead $ mapM_ (\v -> th ! cls v $ toHtml v) ["URL", "Method", "Description", "Input", "Output", "Errors", "Parameters"] tbody $ flip mapM_ (zip [(1 :: Int)..] urlInfo) $ \(n, (url, ais)) -> do tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-main-row") $ mapM_ td $ [ linkHtml $ url , toHtml $ show $ method $ P.head ais , toHtml $ mkActionDescription (resName it) $ P.head ais , dataDescriptions "None" $ inputs $ P.head ais , dataDescriptions "None" $ outputs $ P.head ais , dataDescriptions "None" $ errors $ P.head ais , toHtml $ if null (params (P.head ais)) then "None" else intercalate ", " $ params $ P.head ais ] flip mapM_ (tail ais) $ \ai -> tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-data-row") $ mapM_ td $ [ return () , toHtml $ show $ method ai , toHtml $ mkActionDescription (resName it) ai , dataDescriptions "None" (inputs ai) , dataDescriptions "None" (outputs ai) , dataDescriptions "None" (errors ai) , toHtml $ if null (params ai) then "None" else intercalate ", " $ params ai ] -- | Generate information for input/output data structure dataDescriptions :: String -> [DataDescription] -> Html dataDescriptions s [] = toHtml s dataDescriptions _ descs = table ! cls "data-description" $ do tr $ forM_ descs $ \dsc -> td $ toHtml . L.get (dataTypeDesc . meta) $ dsc tr $ forM_ descs $ \dsc -> td $ do forM_ (L.get (dataSchema . meta) dsc) $ mkCode (typeLang (L.get (dataType . desc) dsc)) "Schema" forM_ (L.get (dataExample . meta) dsc) $ mkCode (typeLang (L.get (dataType . desc) dsc)) "Example" where typeLang XML = "xml" typeLang JSON = "js" typeLang _ = "" -- | Helper function for setting the right attributes to make something collapsible. -- The javascript prt can be found in docs.js mkCode :: String -> String -> String -> Html mkCode lng cap cd = let eid = "idv" ++ show (hash cd) in do div ! cls "modal hide fade code" ! id (toValue eid) $ do cdiv "modal-header" $ do a ! href (toValue "#") ! cls "close" $ toHtml "x" h3 $ toHtml cap cdiv "modal-body" $ div ! style (toValue "overflow:auto; max-height:600px") $ pre ! cls ("prettyprint lang-" ++ lng) $ toHtml $ cd button ! cls "btn open-modal" ! customAttribute (fromString "data-controls-modal") (toValue eid) ! customAttribute (fromString "data-backdrop") (toValue "true") ! customAttribute (fromString "data-keyboard") (toValue "true") $ toHtml cap resourceId :: ResourceId -> String resourceId = intercalate "." resourceDisp :: ResourceId -> Html resourceDisp = toHtml . intercalate "/" resourceLinkAnchor :: ResourceId -> Html -> Html resourceLinkAnchor rid = a ! cls "resource-link" ! href (toValue $ "#" ++ resourceId rid) resourceLinkRemote :: String -> ResourceId -> Html -> Html resourceLinkRemote rUrl rid = a ! cls "resource-link" ! href (toValue $ rUrl ++ intercalate "/" rid) resourceAnchor :: ResourceId -> Html resourceAnchor rid = a ! name (toValue $ resourceId rid) $ return () linkHtml :: Link -> Html linkHtml = mapM_ linkItem where linkItem (LParam idf) = toHtml ("/<" ++ idf ++ ">") linkItem (LAccess lnks) = span ! class_ (toValue "link-block") $ sequence_ $ intersperse br $ map linkHtml $ reverse $ sortBy (compare `on` length) lnks linkItem x = toHtml ("/" ++ itemString x)