Util.hs

module DarcsDen.Util
(module DarcsDen.Util, module DarcsDen.Debug)
where

import Control.Monad (unless, when)
import Data.Char (isAlphaNum, isSpace)
import System.Directory
import Text.Pandoc
import Data.Text.Encoding
import Text.Blaze.Html (toHtml)
import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import Network.HTTP.Conduit (Request, host, path, queryString)

import DarcsDen.Debug


recursively :: (FilePath -> IO ()) -> FilePath -> IO ()
recursively f p = do
    dir <- doesDirectoryExist p
    if dir
        then do
            f p
            contents <- getDirectoryContents p
            mapM_ (recursively f . ((p ++ "/") ++)) $
                filter (\d -> d /= "." && d /= "..") contents
        else f p

recursivelyOnDirs :: (FilePath -> IO ()) -> FilePath -> IO ()
recursivelyOnDirs f =
    recursively $ \p -> do
        dir <- doesDirectoryExist p
        when dir (f p)

recursivelyOnFiles :: (FilePath -> IO ()) -> FilePath -> IO ()
recursivelyOnFiles f =
    recursively $ \p -> do
        dir <- doesDirectoryExist p
        unless dir (f p)

toMaybe :: [a] -> Maybe [a]
toMaybe [] = Nothing
toMaybe x = Just x

paginate :: Int -> Int -> [a] -> [a]
paginate perpage page = take perpage . drop (perpage * (page - 1))

toBS :: String -> BS.ByteString
toBS = encodeUtf8 . T.pack

fromBS :: BS.ByteString -> String
fromBS = T.unpack . decodeUtf8

toBLBS :: String -> LBS.ByteString
toBLBS = LBS.pack . map (toEnum . fromEnum)

fromBLBS :: LBS.ByteString -> String
fromBLBS = map (toEnum . fromEnum) . LBS.unpack

toLBS :: String -> LBS.ByteString
toLBS = LBS.fromChunks . (:[]) . encodeUtf8 . T.pack

fromLBS :: LBS.ByteString -> String
fromLBS = fromBS . strictLBS

strictLBS :: LBS.ByteString -> BS.ByteString
strictLBS = BS.concat . LBS.toChunks

strictTake :: Integral n => n -> LBS.ByteString -> BS.ByteString
strictTake n = strictLBS . LBS.take (fromIntegral n)

strip :: String -> String
strip = strip' . strip'
  where
    strip' = reverse . dropWhile isSpace

doMarkdown :: String -> String
doMarkdown
    = fixEscapes
    . writeHtmlString def
    . readMarkdown def
    . renderHtml
    . toHtml
    . normalize

doMarkdown' :: String -> String
doMarkdown' =
      fixEscapes
    . writeHtmlString def
    . readMarkdown def
    . normalize

normalize :: String -> String
normalize "" = ""
normalize ('\r':'\n':cs) = '\n' : normalize cs
normalize ('\r':cs) = '\n' : normalize cs
normalize (c:cs) = c : normalize cs

fixEscapes :: String -> String
fixEscapes "" = ""
fixEscapes ('&':'a':'m':'p':';':ss) | and [not (null ele), not (null rest), head rest == ';', all isAlphaNum ele]
  = '&' : ele ++ fixEscapes rest
  where (ele, rest) = span (/= ';') ss
fixEscapes (s:ss) = s : fixEscapes ss

-- Convert a patch author string not corresponding to a local user to
-- something suitable for display, not revealing the full email address.
safeAuthorFrom :: String -> String
safeAuthorFrom s =
  case parseNameAndEmail s of
  ("","") -> ""
  ("",e) -> takeWhile (/='@') e
  (n,_) -> n

nameFrom :: String -> String
nameFrom = fst . parseNameAndEmail

emailFrom :: String -> String
emailFrom = snd . parseNameAndEmail

-- Parse a real-name-and-email-address string into name and email address
-- more or less following the usual <> and () conventions. May return the
-- empty string for either or both parts.
parseNameAndEmail :: String -> (String, String)
parseNameAndEmail s
  | '<' `elem` s && '>' `elem` s =
    let (a,bc) = span (/= '<') s
        (b,c') = span (/= '>') $ dropWhile (=='<') bc
        c = dropWhile (== '>') c'
    in (strip $ unwords $ words $ a++c, strip b)
  | '(' `elem` s && ')' `elem` s =
    let (a,bc) = span (/= '(') s
        (b,c') = span (/= ')') $ dropWhile (=='(') bc
        c = dropWhile (== ')') c'
    in (strip b, strip $ unwords $ words $a++c)
  | '@' `elem` s = ("", strip s)
  | otherwise = (strip s, "")

toUrl :: Request m -> BS8.ByteString
toUrl r = BS8.concat [BS8.pack "https://", host r, path r, BS8.singleton '?', queryString r]