{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module KeyRing where

import System.Environment
import Control.Monad
import Data.Maybe
import Data.Char
import Data.List
import Control.Applicative ( (<$>) )
import System.Directory    ( getHomeDirectory, doesFileExist )
import Control.Arrow       ( first, second )

import DotLock

data HomeDir =
    HomeDir { homevar :: String
            , appdir :: String
            , optfile_alts :: [String]
            }

home = HomeDir
    { homevar = "GNUPGHOME"
    , appdir  = ".gnupg"
    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
    }

data InputFile = HomeSec | HomePub | ArgFile FilePath

data KeyRingRuntime = KeyRingRuntime
                        { rtPubring :: FilePath
                        , rtSecring :: FilePath
                        , rtRings :: [FilePath]
                        , rtWallets :: [FilePath]
                        , rtGrip :: Maybe String
                        }

data KeyRingData a = KeyRingData
    { filesToLock :: [InputFile]
    , homeSpec :: Maybe String
    , kaction :: KeyRingRuntime -> IO a
    , keyringFiles :: [FilePath]
    , walletFiles :: [FilePath]
    }

todo = error "unimplemented"

data KikiResult = KikiSuccess | FailedToLock [FilePath]

{-
newtype KeyRing a = KeyRing
    { krAction :: KeyRingData b -> IO a
    }
-}

empty = KeyRingData { filesToLock = []
                    , homeSpec = Nothing
                    , kaction = \KeyRingRuntime {} -> return ()
                    , keyringFiles = []
                    , walletFiles = []
                    }

{-
runKeyRing :: KeyRing () -> IO a
runKeyRing keyring = krAction keyring empty
-}


runKeyRing :: KeyRingData a -> IO KikiResult
runKeyRing keyring = do
    (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
    let tolocks = map resolve (filesToLock keyring)
                  where resolve (ArgFile f) = f
                        resolve HomePub     = pubring
                        resolve HomeSec     = secring
    lks <- forM tolocks $ \f -> do
        lk <- dotlock_create f 0
        v <- flip (maybe $ return Nothing) lk $ \lk -> do
                e <- dotlock_take lk (-1)
                if e==0 then return $ Just lk
                        else dotlock_destroy lk >> return Nothing
        return (v,f)
    let (lked, map snd -> failed) = partition (isJust . fst) lks
        ret = if null failed then KikiSuccess else FailedToLock failed

    case ret of
      KikiSuccess -> kaction keyring KeyRingRuntime
                        { rtPubring = pubring
                        , rtSecring = secring
                        , rtRings = secring:pubring:keyringFiles keyring
                        , rtWallets = walletFiles keyring
                        , rtGrip = grip0
                        }
      _ -> return undefined

    forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                         dotlock_destroy lk
    return ret

parseOptionFile fname = do
    xs <- fmap lines (readFile fname)
    let ys = filter notComment xs
        notComment ('#':_) = False
        notComment cs      = not (all isSpace cs)
    return ys

getHomeDir protohome = do
        homedir <- envhomedir protohome
        flip (maybe (error "Could not determine home directory."))
             homedir $ \homedir -> do
        -- putStrLn $ "homedir = " ++show homedir
        let secring = homedir ++ "/" ++ "secring.gpg"
            pubring = homedir ++ "/" ++ "pubring.gpg"
        -- putStrLn $ "secring = " ++ show secring
        workingkey <- getWorkingKey homedir
        return (homedir,secring,pubring,workingkey)
 where
    envhomedir opt = do
        gnupghome <- lookupEnv (homevar home) >>=
                  \d -> return $ d >>= guard . (/="") >> d
        homed <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        let homegnupg = (++('/':(appdir home))) <$> homed
        let val = (opt `mplus` gnupghome `mplus` homegnupg)
        return $ val
    
    -- TODO: rename this to getGrip
    getWorkingKey homedir = do
        let o = Nothing
            h = Just homedir
        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
                let optfiles = map (second ((h++"/")++))
                                   (maybe optfile_alts' (:[]) o')
                    optfile_alts' = zip (False:repeat True) (optfile_alts home)
                    o' = fmap (False,) o
                in filterM (doesFileExist . snd) optfiles
        args <- flip (maybe $ return []) ofile $
            \(forgive,fname) -> parseOptionFile fname
        let config = map (topair . words) args
                        where topair (x:xs) = (x,xs)
        return $ lookup "default-key" config >>= listToMaybe

#if MIN_VERSION_base(4,6,0)
#else
lookupEnv var =
    handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif