-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module Database where

-- TODO: use ByteString everywhere

import Control.Applicative
import Control.Monad
import System.IO
import System.FilePath
import System.Directory
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as CL
import qualified Data.ByteString.Char8 as CS

--import OpenSSL.Digest (MessageDigest(SHA1), toHex)
--import OpenSSL.Digest.ByteString.Lazy (digest)
--import Data.Digest.Pure.SHA (sha1, showDigest)
--see also OpenSSL.EVP.Digest from HsOpenSSL
import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString)

import Protocol
import Metagame
import Lock
import Mundanities

--hash :: String -> IO String
--hash str = fmap (>>=toHex) $ digest SHA1 $ CL.pack $ str
sha1 :: CL.ByteString -> Digest SHA1
sha1 = hashlazy
hash :: String -> String
hash = CS.unpack . digestToHexByteString . sha1 . CL.pack


data Record
    = RecPassword Codename
    | RecUserInfo Codename
    | RecUserInfoLog Codename
    | RecLock LockSpec
    | RecNote NoteInfo
    | RecLockHashes
    | RecRetiredLocks Codename
    | RecServerInfo
    deriving (Eq, Ord, Show)
data RecordContents
    = RCPassword Password
    | RCUserInfo VersionedUInfo
    | RCUserInfoDeltas [UserInfoDelta]
    | RCLock Lock
    | RCSolution Solution
    | RCLockHashes [String]
    | RCLockSpecs [LockSpec]
    | RCServerInfo ServerInfo
    deriving (Eq, Ord, Show)

rcOfServerResp (ServedServerInfo x) = RCServerInfo x
rcOfServerResp (ServedLock x) = RCLock x
rcOfServerResp (ServedSolution x) = RCSolution x
rcOfServerResp (ServedUserInfo x) = RCUserInfo x
rcOfServerResp (ServedRetired x) = RCLockSpecs x
rcOfServerResp _ = error "no corresponding rc"

invariantRecord (RecUserInfo _) = False
invariantRecord (RecUserInfoLog _) = False
invariantRecord (RecPassword _) = False
invariantRecord (RecRetiredLocks _) = False
invariantRecord (RecNote _) = False
invariantRecord _ = True

askForRecord RecServerInfo = GetServerInfo
askForRecord (RecUserInfo name) = GetUserInfo name Nothing
askForRecord (RecLock ls) = GetLock ls
askForRecord (RecNote note) = GetSolution note
askForRecord (RecRetiredLocks name) = GetRetired name
askForRecord _ = error "no corresponding request"

type DBM = ReaderT FilePath IO
	    
recordExists :: Record -> DBM Bool
recordExists rec = recordPath rec >>= liftIO . doesFileExist

getRecord :: Record -> DBM (Maybe RecordContents)
getRecord rec = do
    path <- recordPath rec
    liftIO $ flip catchIO (const $ return Nothing) $ do
	h <- openFile path ReadMode
	getRecordh rec h <* hClose h
getRecordh (RecPassword _) h = ((RCPassword <$>) . tryRead) <$> hGetStrict h
getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h
getRecordh (RecUserInfoLog _) h = ((RCUserInfoDeltas <$>) . tryRead) <$> hGetStrict h
getRecordh (RecLock _) h = ((RCLock <$>) . tryRead) <$> hGetStrict h
getRecordh (RecNote _) h = ((RCSolution <$>) . tryRead) <$> hGetStrict h
getRecordh RecLockHashes h = ((RCLockHashes <$>) . tryRead) <$> hGetStrict h
getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h
getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h

hGetStrict h = CS.unpack `liftM` concatMWhileNonempty (repeat $ CS.hGet h 1024)
    where concatMWhileNonempty (m:ms) = do
	    bs <- m
	    if CS.null bs
		then return bs
		else (bs `CS.append`) `liftM` concatMWhileNonempty ms

putRecord :: Record -> RecordContents -> DBM ()
putRecord rec rc = do
    path <- recordPath rec
    liftIO $ do
	mkdirhierto path 
	h <- openFile path WriteMode 
	putRecordh rc h
	hClose h
putRecordh (RCPassword hpw) h = hPutStr h $ show hpw
putRecordh (RCUserInfo info) h = hPutStr h $ show info
putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas
putRecordh (RCLock lock) h = hPutStr h $ show lock
putRecordh (RCSolution solution) h = hPutStr h $ show solution
putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes
putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss
putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo

modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()
modifyRecord rec f = do
    h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode 
    liftIO $ do
	Just rc <- getRecordh rec h
	hSeek h AbsoluteSeek 0
	putRecordh (f rc) h
	hTell h >>= hSetFileSize h 
	hClose h

delRecord :: Record -> DBM ()
delRecord rec = recordPath rec >>= liftIO . removeFile

newLockRecord :: Lock -> DBM LockSpec
newLockRecord lock = do
    dbpath <- ask
    let path = dbpath++[pathSeparator]++"lastlock"
    h <- liftIO $ openFile path ReadWriteMode
    contents <- liftIO $ hGetStrict h
    let ls = if null contents then 0 else 1 + read contents
    liftIO $ hSeek h AbsoluteSeek 0
    liftIO $ hPutStr h $ show ls
    liftIO $ hClose h
    putRecord (RecLock ls) (RCLock lock)
    return ls

listUsers :: DBM [Codename]
listUsers = do
    dbpath <- ask
    liftIO $ (map unpathifyName . filter ((==3).length)) <$> getDirectoryContents (dbpath++[pathSeparator]++"users")

recordPath :: Record -> DBM FilePath
recordPath rec = do
	dbpath <- ask
	return $ dbpath ++ [pathSeparator] ++ recordPath' rec
    where
	recordPath' (RecPassword name) = userDir name ++ "passwd"
	recordPath' (RecUserInfo name) = userDir name ++ "info"
	recordPath' (RecUserInfoLog name) = userDir name ++ "log"
	recordPath' (RecLock ls) = locksDir ++ show ls
	recordPath' (RecNote (NoteInfo name _  alock)) = userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock
	recordPath' (RecRetiredLocks name) = userDir name ++ "retired"
	recordPath' RecLockHashes = "lockHashes"
	recordPath' RecServerInfo = "serverInfo"

	userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
	alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
	locksDir = "locks"++[pathSeparator]

-- dummy out characters which are disallowed on unix or windows:
pathifyName = map $ \c -> case c of 
    '/'->'s'
    '.'->'d'
    '\\'->'b'
    '<'->'l'
    '>'->'g'
    ':'->'c'
    '|'->'p'
    '?'->'q'
    '*'->'a'
    _ -> c
unpathifyName = map $ \c -> case c of 
    's'->'/'
    'd'->'.'
    'b'->'\\'
    'l'->'<'
    'g'->'>'
    'c'->':'
    'p'->'|'
    'q'->'?'
    'a'->'*'
    _ -> c