{- # 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)
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

getNewSecretcode :: String -> IO String
getNewSecretcode ip = do
   otp <- otpNew (60*60)
   let result = md5 (otp ++ ip)
   return result

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

isLoggedIn environ = do
   ip <- getIP environ
   let cookie = case lookup "HTTP_COOKIE" environ of
              Nothing -> ""
              Just cookieStr -> getKey "LoggedIn" cookieStr
   yn <- otpCheckGeneral cookie (\otp -> md5 (otp ++ ip))
   return yn

-- 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 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=3600; Version=1; Path=/"
                  putStr httpheader
                  template 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 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 loggedin "You don't have permission to access this page." "Home" root (root++"Home.txt")
                else template loggedin "" page root file
     else if loggedin
            then template loggedin ("Page `"++ page ++"' doesn't exist but you can add it.") page root (root++"add.txt")
            else template loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt") `catch` basehandler


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

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

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

procRename env = do
   let page = dlookup "Home" "page" env
   let loggedin = read $ dlookup "False" "loggedin" env
   let file = dlookup "<can't fail>" "file" env
   putStr httpheader
   fileExists <- doesFileExist (root++page++".txt")
   if not loggedin
     then if fileExists
            then template loggedin "You are not logged in." page root (root++"login.txt")
            else template loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt")
     else if fileExists
            then template loggedin "" page root (root++"rename.txt")
            else template 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 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 loggedin "You are not logged in." page root (root++"login.txt")
            else template loggedin ("Page "++ page ++" doesn't exist. Login to add it.") "Home" root (root++"login.txt")
     else template 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
   -- TODO make " " or "+" change automatically as if user type _ instead
   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 = if "link" `elem` tags then setFolder "links" pageraw else pageraw
   putStr httpheader
   if not loggedin
     then template loggedin "You are not logged in." page root (root++"login.txt")
     else if newCnts == "" then template 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 loggedin "Page updated." page root file

procMovepage env = do
   let page = dlookup "Home" "page" env
   let newpagename = dlookup "" "newpagename" env
   let loggedin = read $ dlookup "False" "loggedin" 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 loggedin "You are not logged in." page root (root++"login.txt")
     else do renameFile oldfile newfile
             renameFile oldtagsfile newtagsfile
             template 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
   let page = dlookup "all" "page" 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 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 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)]

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
   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             <- isLoggedIn osEnviron
   let loggedin   = ("loggedin", show li)
{-
   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) : loggedin :
                       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