{- # O P T I O N S _ GHC -fglasgow-exts  # -}

module Main ( main ) where

import System.IO
import System.Environment
import System.Directory
import Network.URI (unEscapeString)
import List (unionBy, union, sortBy, sort, nubBy, intersperse)
import Control.Monad (liftM)
import System.Time
import System.Locale
import Char (toLower, toUpper)

import Doc (strip)
import Template (template, navigation)
import MD5 (md5)
import OTP (otpCheck, otpCheckGeneral, otpNew)

import Useful -- really useful functions ( split, tuple, replace, etc. )

data Eq a => BoolOp a = Has a | And [BoolOp a] | Or [BoolOp a] | Not (BoolOp a) deriving (Show, Eq)

contenttype = "Content-Type: text/html; charset=utf-8"
httpheader  = contenttype ++ "\n\n"

-------------------------------
-- Cookies and login

getKey key cookieStr =
    let cookieEnv = toEnv cookieStr
    in case lookup key cookieEnv of
          Nothing -> ""
          Just val -> val

expiration = 60*60 -- one hour

getNewSecretcode :: String -> String -> IO String
getNewSecretcode user ip = do
   otp <- otpNew expiration
   let result = secretFunc otp user ip
   return result

secretFunc otp user ip = md5 (md5 (otp ++ user) ++ ip)

getIP :: [(String,String)] -> IO String
getIP environ = do
   return $ dlookup "" "REMOTE_ADDR" environ

isLoggedIn environ = do
   ip <- getIP environ
   let (checksum, user) = case lookup "HTTP_COOKIE" environ of
              Nothing -> ("","")
              Just cookieStr -> (getKey "LoggedIn" cookieStr, getKey "User" cookieStr)
   yn <- otpCheckGeneral checksum (\otp -> secretFunc otp user ip)
   return (yn, user)

-- end Cookies and login
----------------------------

parseQueryString qstr = case qstr of
  ""   -> [("page", "Home"), ("action", "view")]
  qstr -> result
       where result | '=' `elem` qstr = map tuple (split '&' qstr)
                    | otherwise       = [("page", qstr), ("action", "view")]

parseCnts cs = map tuple (split '&' cs)

---------------
-- Note: this needs a trailing slash on the end!
--root = "/Users/jared/Documents/UpdikeOrg/"
--root = "/Library/WebServer/CGI-Executables/"
--root = "/Users/jared/Documents/WebData/"
--root = "/Library/WebServer/Documents/WebData/"
--root = "/home/htdocs/webdata/"
root = "/home/protected/webdata/"
---------------

procValidate env = do
   let username = dlookup "" "username" env
   let password = dlookup "" "password" env
   let page = dlookup "Home" "page" env
   let file = dlookup "<can't fail>" "file" env
   let ip = dlookup "" "ip" env
   ps <- myreadFile "/home/protected/passwd"
   let userPasswdsEnv = map tuple (lines ps)
   -- use one time password to prevent replay attacks
   let otp = dlookup "" "otp" env
   otpValid <- otpCheck otp
   let realPasswd = dlookup "" username userPasswdsEnv
   -- note: we expect the client (JavaScript) to scramble the password exactly like this
   let scrambled = md5 (realPasswd ++ otp)
   let valid = otpValid && password == scrambled

   if valid
     then --let secretcode = ip in
          do secretcode <- getNewSecretcode username ip --let secretcode = ip -- secretcode <- getsecretcode ip
             if secretcode == ""
               then do
                 let message = "Could not give your browser a cookie because \
                               \this server could not uniquely identify your computer."
                 template "" False message page root file
               else do
                  putStrLn$ "Set-Cookie: LoggedIn="++secretcode++"; Max-Age="++show expiration++"; Version=1; Path=/"
                  putStrLn$ "Set-Cookie: User="++username++"; Max-Age="++show expiration++"; Version=1; Path=/"
                  putStr httpheader
                  template username True "Log in successful." page root file
     else do
       putStr httpheader
       template "" False "Access denied." page root file

basehandler ioerr = do
   putStr httpheader
   putStrLn $ "<br />IO ERROR: "++ show ioerr

writehandler ioerr = do
   putStrLn "<br />WRITE "
   basehandler ioerr
   return ()

fxandler ioerr = do
   putStrLn "<br />FILE EXISTS "
   basehandler ioerr
   return ()

readhandler ioerr = do
   putStrLn "<br />READ "
   basehandler ioerr
   return ""

procView env = do
{-
   putStr httpheader

   let page = dlookup "Home" "page" env
   --let loggedin = read $ dlookup "False" "loggedin" env
   let file = dlookup "<can't fail>" "file" env
   let f = (root++page++".txt")
   fileExists <- doesFileExist f `catch` fxhandler
   if fileExists
     then putStrLn$ "File "++f++" exists"
     else putStrLn$ "File "++f++" doesn't exist" ---- Apache says the file (/Users/jared/Documents/UpdikeOrg/Home.txt) doesn't exist,
                                                 ---- but when I run it as me it says it does exist
   str <- myreadFile f
   putStrLn str
-}
   let user = dlookup "" "user" env
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let file = dlookup "<can't fail>" "file" env
   fileExists <- doesFileExist (root++page++".txt")
   putStr httpheader
   if fileExists
     then do tagstr <- myreadFile (root++page++".tags")
             let hidden = (or $ map (=="toberemoved") $ lines tagstr) || (or $ map (=="hidden") $ lines tagstr)
             if hidden && not loggedin
                then template user loggedin "You don't have permission to access this page." "Home" root (root++"Home.txt")
                else template user loggedin "" page root file
     else if loggedin
            then template user loggedin ("Page `"++ page ++"' doesn't exist but you can add it.") page root (root++"add.txt")
            else template user loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt") `catch` basehandler

procNavigation env = do
   let page = "navigation"
   let file = (root++page++".txt")
   let user = dlookup "" "user" env
   let loggedin = read $ dlookup "False" "loggedin" env
   --template user loggedin "" page root file
   putStr httpheader
   navigation user loggedin root

procLogin env = do
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let user = dlookup "" "user" env
   let file = dlookup "<can't fail>" "file" env
   putStr httpheader
   if loggedin
     then template user loggedin "You are already logged in." page root file
     else template user loggedin "" page root (root++"login.txt")

procLogout env = do
   let page = dlookup "Home" "page" env
   let file = dlookup "<can't fail>" "file" env
   let user = ""
   -- clear cookies
   putStrLn "Set-Cookie: LoggedIn=rutabaga; Max-Age=0; Version=1; Path=/"
   putStrLn "Set-Cookie: User=rutabaga; Max-Age=0; Version=1; Path=/"
   putStr httpheader
   fileExists <- doesFileExist (root++page++".txt")
   if fileExists
     then template user False "Logged out." page root file
     else template user False "Logged out." "Home" root file

procEdit env = do
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let user = dlookup "" "user" env
   let file = dlookup "<can't fail>" "file" env
   putStr httpheader
   fileExists <- doesFileExist (root++page++".txt")
   if not loggedin
     then if fileExists
            then template user loggedin "You are not logged in." page root (root++"login.txt")
            else template user loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt")
     else if fileExists
            then template user loggedin "" page root (root++"edit.txt")
            else template user loggedin "" "Home" root (root++"Home.txt")

procRename env = do
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let user = dlookup "" "user" env
   let file = dlookup "<can't fail>" "file" env
   putStr httpheader
   fileExists <- doesFileExist (root++page++".txt")
   if not loggedin
     then if fileExists
            then template user loggedin "You are not logged in." page root (root++"login.txt")
            else template user loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt")
     else if fileExists
            then template user loggedin "" page root (root++"rename.txt")
            else template user loggedin ("Page "++ page ++" doesn't exist so you can't rename it.") "Home" root (root++"Home.txt")

procAdd env = do
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let user = dlookup "" "user" env
   let file = dlookup "<can't fail>" "file" env
   let datestr = dlookup "untitled" "datestr" env
   putStr httpheader
   fileExists <- doesFileExist (root++page++".txt")
   if not loggedin
     then if fileExists
            then template user loggedin "You are not logged in." page root (root++"login.txt")
            else template user loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt")
     else template user loggedin "" datestr root (root++"add.txt")

lowCmp x y = map toLower x `compare` map toLower y
lowEq  x y = map toLower x == map toLower y

updateTagsWith root tags = do
   allstr <- myreadFile (root++"tags.txt")
   let alltags = lines allstr
   let newtags = sortBy lowCmp $ union tags alltags
   mywriteFile (root++"tags.tmp") $ unlines newtags
   removeFile (root++"tags.txt")
   renameFile (root++"tags.tmp") (root++"tags.txt")
   removeOldTags root

removeOldTags root = do
   pairs <- getAllFilesTags
   let alltags = nubBy lowEq $ sortBy lowCmp $ concat [sortBy lowCmp xs | (_,xs) <- pairs]
   --mywriteFile (root++"tags.allnew") $ unlines alltags
   mywriteFile (root++"tags.tmp") $ unlines alltags
   removeFile (root++"tags.txt")
   renameFile (root++"tags.tmp") (root++"tags.txt")

mywriteFile a b = writeFile a b `catch` writehandler
myreadFile x = do s <- readFile x `catch` readhandler
                  return s

setFolder folder page = if length pieces > 1 then page else folder++"/"++page
   where pieces = split '/' page

procModify env = do
   -- make " " or "+" change automatically as if user type _ instead
   let user = dlookup "" "user" env
   let pageraw = replace "+" "_" $ replace " " "_" $ unEscapeString $ dlookup "Home" "page" env
   let newCnts = fixEndingNewlines $ unEscapeString $ replace "+" " " $ dlookup "" "content" env
   let tagsbox = unEscapeString $ replace "\n" "" $ replace "+" " " $ dlookup "" "tagsbox" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let file = dlookup "<can't fail>" "file" env
   let checktags = map (tagdecode . drop 4 . fst) $ filter (\(x,y)-> x `beginsWith` "TAG_" && y=="on") env
   let tags = sortBy lowCmp $ union checktags (filter (/="") $ map strip $ split ',' tagsbox)
   let page = pageraw -- let page = if "link" `elem` tags then setFolder "links" pageraw else pageraw
   putStr httpheader
   if not loggedin
     then template user loggedin "You are not logged in." page root (root++"login.txt")
     else if newCnts == "" then template user loggedin "Nothing to change." page root (root++"login.txt")
       else do
         mywriteFile (root++page++".txt") newCnts
         mywriteFile (root++page++".tags") $ unlines tags
         updateTagsWith root tags
         --putStrLn newCnts
         template user loggedin "Page updated." page root file

procMovepage env = do
   let page = dlookup "Home" "page" env
   let newpagename = replace "+" "_" $ replace " " "_" $ dlookup "" "newpagename" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let user = dlookup "" "user" env

   let oldfile = unEscapeString $ dlookup "<can't fail>" "file" env
   let newfile = unEscapeString $ root++newpagename++".txt"

   let oldtagsfile = unEscapeString $ replace ".txt" ".tags" oldfile
   let newtagsfile = unEscapeString $ root++newpagename++".tags"

   putStr httpheader
   if not loggedin
     then template user loggedin "You are not logged in." page root (root++"login.txt")
     else do renameFile oldfile newfile
             renameFile oldtagsfile newtagsfile
             template user loggedin ("Page "++page++" renamed to "++newpagename++".") newpagename root (root++newpagename++".txt")

toFunc :: Eq a => (a -> a) -> BoolOp a -> [a] -> Bool
toFunc f boolop tags = fnFromBoolOp boolop tags where
   fnFromBoolOp (Has x ) y = f x `elem` y
   fnFromBoolOp (Not x ) y = not (fnFromBoolOp x y)
   fnFromBoolOp (And xs) y = and [fnFromBoolOp x y | x <- xs]
   fnFromBoolOp (Or  xs) y = or  [fnFromBoolOp x y | x <- xs]

getAllFilesTags :: IO [(String, [String])]
getAllFilesTags = do
   allfiles <- getDirectoryContents root
   let files = [x | x <- allfiles, x `endsWith` ".tags"]
   contentses <- mapM (\ file -> readFile (root++file)) files
   return [(reverse (reverse file `dropping` reverse ".tags"), lines cnts)
          | (file,cnts) <- zip files contentses]

procTags env = do
   -- use the name of the page for the name of the tag to filter on
   let page = dlookup "all" "page" env
   let user = dlookup "" "user" env
   let loggedin :: Bool ; loggedin = read $ dlookup "False" "loggedin" env
   let boolop = And (let hide = (if loggedin then [Not (Has "toberemoved")] else [Not (Has "toberemoved"), Not (Has "hidden"), Not (Has "system")])
                  in if map toLower page == "all"
                   then Not (Has "recipes"):hide
                   else [Has page] ++ hide)
   let tagsPred = toFunc (map toLower) boolop
   allFilesTags <- getAllFilesTags
   let filterFilesTags = [(filename, tags) | (filename, tags) <- allFilesTags, tagsPred tags]
   putStr httpheader
   let result = "==== "++page++"\n" ++
                concatMap entry filterFilesTags
                       where entry (file, tags) =
                                "- [[lnk:/articles/"++file++" "++(tagdecode file)++"]] "++
                                " ~~~~~~~~ "++ linkize tags ++
                                "\n"
                             linkize tags = concat $ intersperse ", " $ map (\tag-> "[["++tag++" lnk:/tags/"++tag++"]]") tags
   template user loggedin "" "Home" root ('-':result)

---------------

upperfirst [] = []
upperfirst (x:xs) = toUpper x : xs

firstThatExists [] _ = return Nothing
firstThatExists (s:ss) root = do
   exists <- doesFileExist (root++s)
   if exists then return$ Just s else
      firstThatExists ss root

findBestMatch page = do
   let blahPlus ext  = page ++ ext
   let lblahPlus ext = map toLower page ++ ext
   let ublahPlus ext = (upperfirst . map toLower) page ++ ext
   firstThatExists [ blahPlus ".txt"
                   , blahPlus ".lhs"
                   , blahPlus ".hs"
                   , lblahPlus ".txt"
                   , lblahPlus ".lhs"
                   , lblahPlus ".hs"
                   , ublahPlus ".txt"
                   , ublahPlus ".lhs"
                   , ublahPlus ".hs"
                   ] root

dlookup d k env =
    case lookup k env of
       Nothing -> d
       Just a -> a

actionsEnv = [("view", procView), ("login", procLogin), ("validate", procValidate),
              ("logout", procLogout), ("edit", procEdit), ("modify", procModify), ("add", procAdd),
              ("rename", procRename), ("movepage", procMovepage), ("tags", procTags),
              ("navigation", procNavigation)]

ff osEnviron = case lookup "HTTP_COOKIE" osEnviron of
       Nothing -> []
       Just cookieStr -> toEnv cookieStr

main = do
   -- handle get and post input as well as cookies
   cnts'          <- getContents -- POST method
   let cnts       = replace "\n" "" cnts'
   mywriteFile "/home/protected/POST.log" cnts
   -- let cnts = ""
   osEnviron      <- getEnvironment
   let qstr       = unEscapeString $ dlookup "" "QUERY_STRING" osEnviron -- GET method
   let ip         = dlookup "" "REMOTE_ADDR" osEnviron
   (li, user)     <- isLoggedIn osEnviron
{-
   putStrLn httpheader
   putStrLn $ show osEnviron

   let k = ff osEnviron
   putStrLn $ "----------<br/> " ++ show k
-}
   {-
   time <- getClockTime
   ctime <- toCalendarTime time
   let CalendarTime { ctTZ = gimme } = ctime
   let datestr    = show gimme
   --let datestr    = formatCalendarTime defaultTimeLocale "%Y%m%d%H%M%S" ctime
   -}

   let env'       = ("ip", ip) : ("user",user) : ("loggedin", show li) :
                       unionBy (\x y -> fst x == fst y) (parseCnts cnts) (parseQueryString qstr)

   let curpage    = dlookup "Home" "page" env'
   mBest          <- findBestMatch curpage
   let (bestFname,newpage) = case mBest of
                     Nothing -> ("Home.txt", curpage)
                     Just s  -> (s, takeWhile (/= '.') s)
   let env        = ("page", newpage):("file", root++bestFname) : filter (\x -> fst x /= "page") env'

   let actionName = dlookup "view" "action" env
   case lookup actionName actionsEnv of
      Nothing -> procView env -- default to 'view' if given some invalid action
      Just action -> action env