DevUtils.hs

-- Copyright 2010 Google Inc.
-- 
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
-- 
--      http://www.apache.org/licenses/LICENSE-2.0
-- 
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

module DevUtils (
    devpage,
    Doc(..), documents,
    
    legalPath,
    
    SrcInfo(..), getSrcInfo,
    SrcClass(..),
    previewPath,
    previewLink, editLink, downloadLink, fileLink,
    
    htmlResponse,
    finishWithError, errorBadRequest,
    ) where
    
import qualified Data.ByteString.Char8 as C
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap.Types
import System.Directory
import System.FilePath ((</>), dropExtension, joinPath,
    splitDirectories, takeExtension)
import System.Time (ClockTime, getClockTime)
import Text.Html hiding ((</>))

--
-- DEV PAGE LAYOUT
--

devpage :: HTML a => String -> a -> [Html] -> [String] -> Html
devpage pageTitle contents modules scriptSrcs =
    header << [
      thelink ! [href "/static/barley.css", rel "stylesheet",
                   thetype "text/css"] << noHtml,
      thetitle << fullTitle
      ] +++
    body ! [theclass "with-topbar"] << [
      h1 ! [identifier "logo"] << "Barley",
      thediv ! ([identifier "content"] ++ withSidebar modules) <<
        (toHtml contents +++ toHtml (sidebar modules)),
      topbar,
      scripts scriptSrcs
      ]
  where
    fullTitle = if null pageTitle then "Barley" else "Barley - " ++ pageTitle

sidebar :: [Html] -> Html
sidebar [] = noHtml
sidebar modules = thediv ! [identifier "sidebar"] <<
    map (thediv ! [theclass "module"]) modules

withSidebar :: [Html] -> [HtmlAttr]
withSidebar [] = []
withSidebar _ = [theclass "with-sidebar"]

topbar :: Html
topbar = thediv ! [identifier "topbar"] << [
    ulist ! [theclass "left"] << li <<
         [ anchor ! [href "http://haskell.org/", theclass "logo"] << "Haskell" 
         , unordList $ map makelink communityLinks
         ]
    , ulist ! [theclass "right"] << map li siteLinks
    ]
  where
    makelink (title, url) = anchor ! [href url] << title
    makeDocLink doc = anchor ! [href $ docUrl doc, target "_blank"]
        << docName doc
    communityLinks =
        [ ("Platform", "http://hackage.haskell.org/platform/")
        , ("Hackage", "http://hackage.haskell.org/packages/hackage.html")
        , ("Reddit", "http://www.reddit.com/r/haskell/")
        , ("Stack Overflow",
            "http://stackoverflow.com/questions/tagged?tagnames=haskell")
        ]
    siteLinks =
        [ makelink ("Home", "/")
        , makelink ("Project", "/project")
        , makelink ("Documentation", "/documentation")
          +++ unordList (map makeDocLink documents)
        , makelink ("Help", "/help")
        ]


scripts :: [String] -> Html
scripts = toHtml . map script
  where
    script s = tag "script" ! [ thetype "text/javascript", src s ] << noHtml


data Doc = Doc { docId :: String, docName :: String, docUrl :: String }

documents :: [Doc]
documents =
    [ Doc "ghclibs" "Library" "http://www.haskell.org/ghc/docs/6.12.2/html/libraries/frames.html"
    , Doc "html"    "Text.Html" "http://hackage.haskell.org/packages/archive/html/1.0.1.2/doc/html/Text-Html.html"
    , Doc "snap"    "Snap"    "http://snapframework.com/docs/latest/snap-core/index.html"
    ]

docLocalUrl :: Doc -> String
docLocalUrl doc =  "/documentation?doc=" ++ docId doc



--
-- PROJECT FILE UTILITIES
--

data SrcInfo = SrcInfo { srcPath     :: FilePath -- | path relative to project
                       , srcFullPath :: FilePath -- | absolute path
                       , srcExists   :: Bool
                       , srcWritable :: Bool
                       , srcModTime  :: Maybe ClockTime
                       , srcClass    :: SrcClass
                       }

data SrcClass = SCPage | SCImage | SCScript | SCText | SCOther | SCDir
    deriving (Eq)
    
getSrcInfo :: FilePath -> IO SrcInfo
getSrcInfo path = do
    cwd <- getCurrentDirectory
    isDir <- doesDirectoryExist path
    isFile <- doesFileExist path
    let exists = isDir || isFile
    canWrite <- if exists
        then writable `fmap` getPermissions path 
        else return False -- TODO: should be writable of containing dir
    modTime <- if exists
        then Just `fmap` getModificationTime path
        else return Nothing
    let cls = if isDir
            then SCDir
            else M.findWithDefault SCOther (takeExtension path) extToSrcClass
    return SrcInfo { srcPath = path
                   , srcFullPath = cwd </> path
                   , srcExists = exists
                   , srcWritable = canWrite
                   , srcModTime = modTime
                   , srcClass = cls
                   }

extToSrcClass = M.fromList
    [ (".html", SCPage)
    , (".xhtml",SCPage)
    , (".txt",  SCPage)
    , (".hs",   SCScript)
    , (".css",  SCText)
    , (".js",   SCText)
    , (".json", SCText)
    , (".xml",  SCText)
    , (".gif",  SCImage)
    , (".jpeg", SCImage)
    , (".jpg",  SCImage)
    , (".pdf",  SCImage)
    , (".png",  SCImage)
    , (".svg",  SCImage)
    ]
      
previewPath :: SrcInfo -> Maybe FilePath
previewPath si = if not (srcExists si) || libDir
                        then Nothing
                        else pp $ srcClass si
  where
    libDir = case splitDirectories path of
                        ("lib":_) -> True
                        _ -> False
    path = srcPath si
    pp SCPage = Just path
    pp SCScript = Just $ dropExtension path
    pp SCImage = Just path
    pp _ = Nothing

previewLink :: SrcInfo -> Maybe Html
previewLink si = build (srcClass si) `fmap` previewPath si
  where
    build fc p = anchor ! [href p, target "_blank", theclass "op-preview",
                    title ("View the " ++ long fc ++ "in another window")]
                    << thespan << ("View " ++ short fc)
                    
    short SCPage = "Page"
    short SCScript = "Page"
    short SCImage = "Image"
    short SCText = "Text"
    short SCOther = "File"
    short SCDir = "Dir"

    long SCPage = "page"
    long SCScript = "generated page"
    long SCImage = "image"
    long SCText = "text"
    long SCOther = "file"
    long SCDir = "dir"

editLink :: SrcInfo -> Maybe Html
editLink si = build `fmap` ee (srcClass si)
  where
    build n = anchor ! [href src, theclass "op-edit", title ("Edit the " ++ n)]
                << thespan << "Edit"
    src = "source?file=" ++ srcPath si
    ee SCPage = Just "page"
    ee SCScript = Just "script"
    ee SCText = Just "text"
    ee _ = Nothing
    
downloadLink :: SrcInfo -> Maybe Html
downloadLink si = build `fmap` dd (srcClass si)
  where
    build n = anchor ! [href (srcPath si), theclass "op-download",
                    title ("Download the " ++ n)]
                    << thespan << "Download"
    dd SCText = Just "text"
    dd SCScript = Just "script"
    dd _ = Nothing

fileLink :: SrcInfo -> Maybe Html
fileLink si = Just $ anchor ! [href ("file://" ++ srcFullPath si),
                    theclass "op-file",
                    title "Provides a file:// scheme URL to the local file"]
                    << thespan << "Local File"


-- copied from Barley.Utils for now as there is no way to import it
legalPath :: FilePath -> Maybe FilePath
legalPath p =
    if any illegalComponent components
        then Nothing
        else Just $ joinPath components
  where
    components = splitDirectories p
    illegalComponent "" = True
    illegalComponent ('.':_) = True
    illegalComponent s = any (`elem` "/\\:") s 


--
-- SNAP UTILITIES
--

htmlResponse :: HTML a => a -> Snap ()
htmlResponse html = do
    modifyResponse $ setContentType (C.pack "text/html; charset=UTF-8")
    writeBS $ (T.encodeUtf8 . T.pack) $ renderHtml html

-- copied from Barley.Utils for now as there is no way to import it
  
-- | Immediately finish with an HTTP error status
finishWithError :: Int -> String -> Snap ()
finishWithError status message =
    finishWith $ setResponseStatus status (C.pack message) emptyResponse

-- | Common HTTP error statuses
errorBadRequest :: Snap ()
errorBadRequest = finishWithError 400 "Bad Request"