-- File created: 2008-01-22 20:44:58

module Coadjute.DB (
   Datum, hasHash, dArgs,
   DB (hasHashes), addEntry, dbLookup,
   MDB, loadDataBase, writeDataBase) where

import           Control.Arrow       ((>>>))
import           Control.Monad       (forM_, unless, when, (>=>))
import           Control.Monad.Cont  (ContT, runContT, callCC)
import qualified Data.ByteString as BS
import           Data.ByteString     (ByteString)
import           Data.ByteString.Internal (c2w)
import qualified Data.ByteString.UTF8 as U8
import           Data.Char           (isSpace)
import           Data.List           (intersperse, mapAccumR)
import           Data.Maybe          (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import           Data.Map (Map)
import           Data.Set (Set)
import           Safe                (readDef)
import           System.IO           (withFile, IOMode (WriteMode), hPutStrLn)
import           Text.CSV.ByteString (CSV, Record, Field, parseCSV)
import           Text.Printf         (printf)

import           Coadjute.CoData
import           Coadjute.Hash       (Hash, readHash, showHash)
import           Coadjute.Util.List  (replaceList)

-- Command line arguments and an optional Hash.
data Datum = Datum (Set String) (Maybe Hash)

dArgs :: Datum -> Set String
dArgs (Datum a _) = a

hasHash :: Datum -> Hash -> Bool
(Datum _ Nothing)  `hasHash` _  = False
(Datum _ (Just h)) `hasHash` h' = h == h'

type MDB = Maybe DB
data  DB = DB
   { dbData    :: Map FilePath Datum
   , hasHashes :: Bool
   }

addEntry :: DB -> FilePath -> Set String -> Maybe Hash -> DB
addEntry db file args hash =
   DB (Map.insert file (Datum args hash) (dbData db)) (hasHashes db)

dbLookup :: DB -> FilePath -> Maybe Datum
dbLookup = flip Map.lookup . dbData

loadDataBase :: CoData MDB
loadDataBase = (`runContT` return) . callCC $ \exit -> do
   verbosity <- asks coVerbosity

   forceNoDB <- asks coForceNoDB
   when forceNoDB (exit Nothing)

   exists  <- asks coDBExists
   forceDB <- asks coForceDB
   unless exists $ do
      unless forceDB (exit Nothing)

      notHashing <- asks coForceNoHash
      exit$ Just (DB Map.empty (not notHashing))

   parsed <- io (parseDB dbFileName)
   case parsed of
        Nothing ->
           if forceDB
              then io.ioError.userError$
                 "DB explicitly requested but parse failed, aborting..."
              else do
                 when (verbosity /= Quiet) $
                    io.putStrLn $ "Ignoring DB due to parse error..."
                 return Nothing
        Just db -> do
           when (verbosity >= Verbose) $
              io$ printf
                 "Loaded DB containing %d entries.\n"
                 (Map.size . dbData $ db)
           return (Just db)

-- Reading and Writing
----------------------

dbVerString :: ByteString
dbVerString = U8.fromString "CoadjuteDB v1"

{- Current DB format:
 -    CoadjuteDB v1
 - on its own line. Followed by datums in a CSV format:
 -    filename,[args],[hash]
 - [] denotes optional
 -
 - Filenames must be listed in ascending order, and not duplicated!
 - If the user messes with this, he can't expect stuff to work properly, as
 - these properties are not tested here.
 -}
parseDB :: FilePath -> IO (Maybe DB)
parseDB = BS.readFile >>> fmap (checkFirstLine >=> parseCSV >=> return.csvToDB)

checkFirstLine :: ByteString -> Maybe ByteString
checkFirstLine s =
   let i     = fromMaybe maxBound .
                  BS.findIndex (`BS.elem` U8.fromString "\r\n") $ s
       j     = if BS.index s i == c2w '\r' then 2 else 1
       (v,d) = BS.splitAt i s
    in if v == dbVerString
          then Just (BS.drop j d)
          else Nothing

csvToDB :: CSV -> DB
csvToDB csv =
   let (hadHashes, dats) = mapAccumR scanLine True csv
    in DB (Map.fromDistinctAscList dats) hadHashes

scanLine :: Bool -> Record -> (Bool,(String,Datum))
scanLine _  [path] =
   let p = fromCSVField path
    in (False, (p, Datum Set.empty Nothing))

scanLine _ [path,args] =
   let p = fromCSVField path
       a = readDef [] . fromCSVField $ args
    in (False, (p, Datum (Set.fromDistinctAscList a) Nothing))

scanLine hashes [path,args,hash] =
   let p = fromCSVField path
       a = readDef [] . fromCSVField $ args
       h = fromCSVField hash
    in (hashes, (p, Datum (Set.fromDistinctAscList a)
                          (Just .readHash $ h)))
scanLine _ s =
   error$ "DB :: Invalid datum: '" ++ fromCSVField (BS.concat s) ++ "'"

fromCSVField :: Field -> String
fromCSVField s
   | BS.null s = ""
   | otherwise = unquote (U8.toString s)

-- replace "" with "
unquote :: String -> String
unquote = replaceList "\"\"" "\""

-- Writing
----------

writeDataBase :: MDB -> CoData ()
writeDataBase Nothing   = return ()
writeDataBase (Just db) = do
   io (putDB db dbFileName `catch` f)
   verbosity <- asks coVerbosity
   when (verbosity >= Verbose) $
      io$printf "Wrote DB containing %d entries.\n" (Map.size . dbData $ db)
 where
   f e = putStrLn "DB :: Failed to write DB:" >> ioError e

putDB :: DB -> FilePath -> IO ()
putDB db f = withFile f WriteMode $ \h -> do
   BS.hPutStrLn h dbVerString
   let csv = dbToCSV db
   forM_ csv $ \record -> do
      let rec' = intersperse (U8.fromString ",") (map toCSVField record)
      mapM_ (BS.hPutStr h) rec'
      hPutStrLn h ""

dbToCSV :: DB -> CSV
dbToCSV = map (tupleToRecord . uncurry datToTuple) . Map.toAscList . dbData

datToTuple :: FilePath -> Datum -> (String,String,String)
datToTuple f (Datum args mhash) =
   ( f
   , if Set.null args
        then ""
        else show (Set.toAscList args)
   , maybe "" showHash mhash
   )

tupleToRecord :: (String,String,String) -> Record
tupleToRecord (a,b,c) = map U8.fromString [a,b,c]

toCSVField :: ByteString -> Field
toCSVField s =
   if mustBeQuoted s
      then quote s
      else s

mustBeQuoted :: ByteString -> Bool
mustBeQuoted s | s == BS.empty = False
mustBeQuoted s = or
   [ BS.any (`BS.elem` U8.fromString ",\n\"") s
   , isSpace (head . U8.toString $ s)
   , isSpace (last . U8.toString $ s)
   ]

quote :: ByteString -> ByteString
quote s = BS.concat [qm, f s, qm]
 where
   qm  = BS.singleton (c2w '"')
   dqm = BS.append qm qm
   f = BS.concatMap $
          \c -> let c' = BS.singleton c
                 in if c' == qm
                       then dqm
                       else c'