{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}
import Control.Applicative ( (<$>) )
import Control.Monad ( forM, when, forM_ )
import Control.Monad.Trans ( lift )
import Control.Monad.State ( modify )
import Control.Monad.IO.Class( MonadIO(..) )

import Data.IORef.MonadIO

import System.Console.CmdLib hiding ( summary )
import System.FSLib.IO
import System.FSLib.Hash ( Hash(..), sha256, encodeBase16, encodeBase64u )
import System.FSLib.StoreMonad
import System.Environment ( getEnvironment )

import Text.PrettyPrint.Leijen.Text ( displayT, renderPretty )
import qualified Data.Text as T

import Data.Patch( invert )
import Data.Patch.Apply ( applyToState )
import Data.Patch.Show ( Display, displayEC, summariseEC )
import Data.Patch.ObjectMap ( UUID(..), Object(..), findPath, ObjectType(..), DirContent )
import Data.Patch.Commute ( commute, commuteRLFL )
import Data.Patch.Invert ( invertFL )

import Data.Patch.Prim.V3 ()
import Data.Patch.Prim.V3.Core ( Prim )
import Data.Patch.Info ( PatchInfo, makePI, formatPI, getNiceDate )

import Data.Patch.Diff ( Diff(..), Branched(..), leftmost )
import Data.Path ( (</>), parsePath, Absolute, Relative, SubPath, parent, Split(..)
                 , pathToString, eitherPath, ioAbsolute )
import Witnesses.Sealed
import Witnesses.Ordered ( (:>)(..), FL )

import qualified Data.Text.Lazy as TL
import qualified Data.Path as P ( file )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Codec.Binary.Base16 as B16
import qualified Codec.Binary.Base64Url as B64

import System.PosixCompat.User ( userGecos, getRealUserID, getUserEntryForID )

import Types
import UUID
import Repository
import Shuffle

data ObjectSpec = ObjectId UUID | ObjectPath SubPath | NoObject deriving (Eq, Typeable, Data)

data Cmd = Init { force :: Bool }
         | Add { uuid :: Maybe UUID, file :: String, update :: Bool, force :: Bool }
         | Remove { file :: String }
         | Mv { file :: String, target :: String }
         | Record { message :: String, author :: String }
         | Unrecord {}
         | Cat { object :: ObjectSpec, inPristine :: Bool }
         | Ls { object :: ObjectSpec, inPristine :: Bool }
         | Changes { details :: Bool, summary :: Bool }
         | Whatsnew { summary :: Bool }
         | Status { summary :: Bool }
         | Pull { remote :: Either Absolute Relative }
         deriving (Eq, Typeable, Data)

instance Attributes Cmd where
  attributes _ = group "Options" [
    uuid %> [ Help "Provide a fixed UUID.", Default (Nothing :: Maybe UUID) ],
    message %> [ Short "m", Help "The patch name to record.", Default ("unnamed patch" :: String) ],
    summary %> [ Short "s", Help "Summarise patch(es)." ],
    remote %> [ Required True, Positional 0 ],
    object %> [ Required True, Positional 0 ],
    file %> [ Required True, Positional 0 ],
    target %> [ Required True, Positional 1 ] ]
  readFlag _ = readCommon <+< uuid <+< object <+< eitherPath
    where uuid :: String -> Maybe UUID
          uuid id | null id = Nothing
                  | length id == 64, Just dec <- B16.decode id = Just $ UUID $ B.pack dec
                  | length id == 44, Just dec <- B64.decode id = Just $ UUID $ B.pack dec
                  | last id /= '=', Just id' <- uuid (id ++ "=") = Just id'
                  | otherwise = Nothing
          object id = case uuid id of
            Just x -> ObjectId x
            Nothing -> case parsePath id of
              Just x -> ObjectPath x
              Nothing -> NoObject

instance RecordCommand Cmd where
  mode_summary Init {} = "Create a new repository."
  mode_summary Ls {} = "List repository contents."
  mode_summary Add {} = "Add an object to shadow."
  mode_summary Remove {} = "Remove an object from shadow."
  mode_summary Cat {} = "Display current version of an object."
  mode_summary Whatsnew {} = "Display the difference between pristine and shadow."
  mode_summary Status {} = "Summarise the difference between pristine and shadow."
  mode_summary Changes {} = "List patches recorded in the repository."
  mode_summary Record {} = "Record the difference between pristine and shadow as a patch."
  mode_summary Unrecord {} = "Remove the topmost recorded patch."
  mode_summary Mv {} = "Rename a file in working and in shadow."
  mode_summary Pull {} = "Pull patches from another repository."

  rec_options Cat {} = uuid %> [ Positional 0, Required True ]
  rec_options Ls {} = object %> [ Positional 0, Required False, Default (ObjectId rootUUID) ]
  rec_options Status {} = summary %> [ Default True ]
  rec_options _ = noAttributes

renderString = TL.unpack . displayT . renderPretty 1.0 80

toShadow uuid path =
  do isdir <- doesDirectoryExist path
     editShadow uuid $ if isdir then Directory M.empty
                                else Blob (readFileBS path) TText NoHash

withPaths :: [String] -> ([SubPath] -> Gorsvet a) -> Gorsvet a
withPaths paths act =
  do paths' <- mapM checkPath paths
     act paths'
  where checkPath p = case parsePath p of
          Nothing -> fail $ "Invalid path: " ++ p
          Just p' -> return p'

getInfo :: Cmd -> Gorsvet PatchInfo
getInfo x = do date <- getNiceDate
               gecos <- takeWhile (/=',') . userGecos <$>
                          (liftIO . getUserEntryForID =<< liftIO getRealUserID)
               envmail <- lookup "EMAIL" <$> liftIO getEnvironment
               let aname = case (author x, gecos, envmail) of
                     ("", "", Nothing) -> "anonymous"
                     ("", "", Just em) -> "<" ++ em ++ ">"
                     ("", _, Just em) -> gecos ++ " <" ++ em ++ ">"
                     (_, _, _) -> author x
               name <- return $ T.pack $ message x
               return $ makePI [ ("Author", T.pack aname)
                               , ("Date", date)
                               , ("Name", name) ]

cmd_mv :: Cmd -> Gorsvet ()
cmd_mv x = withPaths [file x, target x] $ \[from, to] -> do
  Just id <- findUUID from
  demanifest from id
  manifest to id
  rename from to

cmd_add :: Cmd -> Gorsvet ()
cmd_add x = withPaths [file x] $ \[path] -> do
  id <- case (uuid x, update x) of
    (Just id, True) -> return id
    (Just id, False) -> case force x of
      True -> return id
      False -> fail "Object already exists. Use --force."
    (Nothing, True) -> findUUID path >>= \(Just x) -> return x
    (Nothing, False) -> do
      mb <- findPath path rootUUID =<< shadow
      case (mb, force x) of
        (Just id, False) -> fail "Object already exists. Use --update or --force."
        _ -> makeUUID
  manifest path id
  toShadow id path
  return ()

cmd_browse :: Cmd -> Gorsvet ()
cmd_browse x =
  case object x of
    NoObject -> fail "An object specifier is required"
    ObjectId id -> dump id
    ObjectPath path -> findUUID path >>= \(Just x) -> dump x
    where dump id = do
            get <- omGet <$> (if inPristine x then pristine else shadow)
            obj <- get id
            case obj of
              Just obj -> (liftIO . putStr) =<< formatObj obj
              Nothing -> fail "Object not found"

cmd_whatsnew :: Cmd -> Gorsvet ()
cmd_whatsnew x =
  do Sealed branched <- unrecordedChanges
     doc <- display (leftmost branched) =<< shadow
     liftIO . putStrLn $ renderString doc
  where display | summary x = summariseEC
                | otherwise = displayEC

unrecordedChanges :: Gorsvet (Sealed (Branched Prim a))
unrecordedChanges =
  do pris <- pristine
     sha <- shadow
     unFreeLeft <$> diff pris sha

main = getArgs >>= dispatchR [] >>= \x -> case x of
  Init {} -> enhancedIO $ do
    when (force x) $ removeRecursively gsdir
    initRepository
  Add {} -> gorsvetRW $ cmd_add x
  Ls {} -> gorsvetRO $ cmd_browse x
  Cat {} -> gorsvetRO $ cmd_browse x

  Remove {} -> gorsvetRW $ withPaths [file x] $ \[path] -> do
    Just id <- findUUID path
    demanifest path id

  Mv {} -> gorsvetRW $ withPaths [file x, target x] $ \[from, to] -> do
    Just id <- findUUID from
    demanifest from id
    manifest to id
    rename from to

  Whatsnew {} -> gorsvetRO $ cmd_whatsnew x
  Status {} -> gorsvetRO $ cmd_whatsnew x

  Changes {} -> gorsvetRO $ do
    ord <- order
    context <- newIORef =<< pristine
    forM_ ord $ \ih -> do
      Just ph <- M.lookup ih <$> inventory
      inf <- load ih
      let hashn = encodeBase16 ph
          fn = objdir </> B.take 2 hashn </> B.drop 2 hashn
      liftIO . putStr . T.unpack . formatPI $ inf
      liftIO . putStrLn $ "Info-Hash: " ++ BC.unpack (encodeBase64u ih)
      liftIO . putStrLn $ "Stored-In: " ++ pathToString fn
      when (details x || summary x) $ do
        patch :: FL Prim x y <- load ph
        let offset = unlines . map (' ':) . lines
            display fun = liftIO . putStr . offset . renderString =<< fun
        when (summary x) $ do
          liftIO . putStrLn $ "Change-Summary: "
          display $ summariseEC patch =<< readIORef context
        when (details x) $ do
          liftIO . putStrLn $ "Patch: "
          display $ displayEC patch =<< readIORef context
        context' <- applyToState (invert patch) =<< readIORef context
        writeIORef context context'
      liftIO . putStrLn $ ""

  Record {} -> gorsvetRW $ do
    Sealed branched <- unrecordedChanges
    info <- getInfo x
    hash <- store $ leftmost branched
    ihash <- store $ info
    editInventory (M.insert ihash hash)
    editOrder (ihash:)
    pristine' <- applyToState (leftmost branched) =<< pristine
    editRepository $ \x -> x { rPristine = pristine' }
    return ()

  Unrecord {} -> gorsvetRW $ do
    ihash <- head <$> order
    Just phash <- M.lookup ihash <$> inventory
    patch :: FL Prim x y <- load phash
    editInventory (M.delete ihash)
    editOrder tail
    applyToState (invert patch) =<< pristine
    return ()

  Pull {} -> gorsvetRW $ do
    rpath <- case remote x of
      Left y -> return y
      Right y -> liftIO $ ioAbsolute y
    modify $ \x -> x { gsRemotes = rpath : gsRemotes x }
    rrepo <- readRepository rpath
    rrepo' <- coShuffle rrepo
    -- our repository and rrepo' have a longest possible common prefix now
    ours <- inventory
    let extra = M.keysSet $ M.difference ours (rInventory rrepo')
        missingM = M.difference (rInventory rrepo') ours
        missing = M.keysSet missingM
        missing' = takeWhile (`S.member` missing) $ rOrder rrepo'
    extra' <- takeWhile (`S.member` extra) <$> order
    forM (S.toList missing) $ \ih -> do
      store =<< (load ih :: Gorsvet PatchInfo)

    -- add the remote patches to our inventory
    editRepository $ \x -> x { rInventory = M.union (rInventory x) missingM }

    when (S.size extra /= length extra') $
      fail "BUG: coShuffle problem with extra"
    when (S.size missing /= length missing') $
      fail "BUG: coShuffle problem with missing"

    liftIO . putStrLn $ "\nPulling patches:"
    forM missing' $ \ih -> do
      inf :: PatchInfo <- load ih
      liftIO . putStr . T.unpack . formatPI $ inf

    r <- repo
    extraFL <- loadFL r $ reverse extra'
    missingFL <- loadFL r $ reverse missing'

    (missingFL' :> _) <- commuteRLFL $ invertFL extraFL :> missingFL
    editRepositoryM $ \r -> storeFL r missingFL'
    editRepositoryM $ \r -> do
      pristine' <- applyToState missingFL' =<< pristine
      shadow' <- applyToState missingFL' =<< shadow
      return $ r { rPristine = pristine', rShadow = shadow' }
    editRepository $ \ x -> x { rOrder = missing' ++ rOrder x }