happs-tutorial-0.8.1: src/Misc.hs

module Misc where 

import Happstack.Server 
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Monad
import Data.List
import Control.Arrow
import Data.Digest.Pure.MD5
import Text.PrettyPrint as PP
import System.FilePath (pathSeparator, takeDirectory)
import System.Directory (createDirectoryIfMissing)
import Safe (readMay)
import System.Time
import Data.Char (isAlphaNum)
import Data.Char (toLower)

pp :: (Show a) => [t] -> [a] -> String
pp [] = PP.render . vcat . map (text . show)
pp _ = undefined

pathPartsSp pps f = do
  rq <- askRq
  if rqPaths rq == pps
    then f rq 
    else mzero

-- Do something when the request has exactly one path segment left.
-- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response
lastPathPartSp0 f = do
  rq <- askRq
  case rqPaths rq of
            [lastpart] -> f rq lastpart
            _ -> mzero

-- store passwords as md5 hash, as a security measure
scramblepass :: String -> String
scramblepass = show . md5 . L.pack

-- HStringTemplate modifications -- copy/paste/tweak from HStringTemplate.
-- same as directoryGroup, but throws an error for template names with punctuation



tFromTo = fromTo 10 20 [1..1000] == [10..20] 
fromTo fr to = take (to-(fr-1)) . drop (fr-1)


quote x = '\"' : x ++ "\"" 

-- Windows/Unix/Mac compatible 
pathstring pathparts =
  let sep :: String
      sep = [pathSeparator] 
  in intercalate sep pathparts

safeRead :: (Monad m, Read a) => [Char] -> m a
safeRead s = 
  maybe (fail $ "safeRead: " ++ s)
        return 
        (readMay s)

timeSince x = do
  currTime <- getClockTime
  return . diffClockTimes currTime $ x

-- splitList 3 [1..11]
-- [([(1,1),(2,2),(3,3)],(1,3)),([(4,4),(5,5),(6,6)],(4,6)),([(7,7),(8,8),(9,9)],(7,9)),([(10,10),(11,11)],(10,11))]
-- the result is a list of (indexed sublist,(fist index, last index))
splitList :: Int -> [b] -> [([b], (Int, Int))]
splitList n x = let
  part = splitList' n ( zip [1..] x) 
  bounded = map (map snd &&& bounds) part
  bounds [] = (0,0)
  bounds l@((_,_):_) = (fst . head $ l,fst . last $ l)
  in bounded
  where 
    splitList' :: Int -> [a] -> [[a]]
    splitList' _ [] = []
    splitList' n l@(x:xs) =
      let (a,b') = genericSplitAt n l
          b = splitList' n b'
      in  a : b


lc = map toLower

-- write a file, creating parent directories if necessary
writeFileForce fp contents = do
  createDirectoryIfMissing True (takeDirectory fp)
  B.writeFile fp contents

-- check if a string is made of alphanumeric plus _
isalphanum_S = null . filter (not . isAlphaNum_)
isAlphaNum_ c = isAlphaNum c || '_' == c || '-' == c

allowedCharactersSnip = "please use only numbers, letters, '-', and '_'."