content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DeriveFunctor, DeriveGeneric, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  module IdeSession.Util (
      -- * Misc util
      showExWithClass
    , accessorName
    , lookup'
    , envWithPathOverride
    , writeFileAtomic
    , setupEnv
    , relInclToOpts
    , parseProgressMessage
    , ignoreDoesNotExist
    , interruptible
      -- * Simple diffs
    , Diff(..)
    , applyMapDiff
      -- * Manipulating stdout and stderr
    , swizzleStdout
    , swizzleStderr
    , redirectStderr
    , captureOutput
    , UnsupportedOnNonUnix(..)
    , ReqRunRpc(..)
  ) where
  
  import Control.Exception
  import Control.Applicative ((<$>))
  import Control.Monad (void, forM_, mplus)
  import Crypto.Classes (blockLength, initialCtx, updateCtx, finalize)
  import Crypto.Types (BitLength)
  import Data.Accessor (Accessor, accessor)
  import Data.Binary (Binary(..))
  import Data.Char (isSpace)
  import Data.Digest.Pure.MD5 (MD5Digest, MD5Context)
  import Data.List (intercalate)
  import Data.Maybe (fromMaybe)
  import Data.Tagged (Tagged, untag)
  import Data.Text (Text)
  import Data.Typeable (typeOf)
  import Foreign.C.Types (CFile)
  import Foreign.Ptr (Ptr, castPtr, )
  import GHC.Generics (Generic)
  import GHC.IO (unsafeUnmask)
  import System.Directory (createDirectoryIfMissing, removeFile, renameFile)
  import System.Environment (getEnvironment, setEnv, unsetEnv)
  import System.FilePath (splitFileName, (<.>), (</>))
  import System.FilePath (splitSearchPath, searchPathSeparator)
  import System.IO
  import System.IO.Error (isDoesNotExistError)
  import Data.Typeable (Typeable)
  import Network
  
  import Foreign.Ptr (nullPtr)
  import System.IO.Temp (withSystemTempFile)
  import IdeSession.Util.PortableIO
  import IdeSession.RPC.Sockets
  import IdeSession.Util.PortableProcess
  
  import System.PosixCompat.Types (CPid(..))
  import Text.Show.Pretty
  import qualified Control.Exception            as Ex
  import qualified Data.Attoparsec.Text         as Att
  import qualified Data.Binary                  as Bin
  import qualified Data.Binary.Builder.Internal as Bin (writeN)
  import qualified Data.Binary.Get.Internal     as Bin (readNWith)
  import qualified Data.Binary.Put              as Bin (putBuilder)
  import qualified Data.ByteString              as BSS
  import qualified Data.ByteString.Lazy         as BSL
  import qualified Data.Text                    as Text
  import qualified Data.Text.Foreign            as Text
  
  import IdeSession.Strict.Container
  import qualified IdeSession.Strict.Map as StrictMap
  
  foreign import ccall "fflush" fflush :: Ptr CFile -> IO ()
  
  {------------------------------------------------------------------------------
    Util
  ------------------------------------------------------------------------------}
  
  -- | Show an exception together with its most precise type tag.
  showExWithClass :: Ex.SomeException -> String
  showExWithClass (Ex.SomeException ex) = show (typeOf ex) ++ ": " ++ show ex
  
  -- | Translate record field '_name' to the accessor 'name'
  accessorName :: String -> Maybe String
  accessorName ('_' : str) = Just str
  accessorName _           = Nothing
  
  -- | Prelude.lookup as an accessor
  lookup' :: Eq a => a -> Accessor [(a, b)] (Maybe b)
  lookup' key =
      accessor (lookup key) $ \mVal list ->
        case mVal of
          Nothing  -> delete key list
          Just val -> override key val list
    where
      override :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
      override a b [] = [(a, b)]
      override a b ((a', b') : xs)
        | a == a'   = (a, b) : xs
        | otherwise = (a', b') : override a b xs
  
      delete :: Eq a => a -> [(a, b)] -> [(a, b)]
      delete _ [] = []
      delete a ((a', b') : xs)
        | a == a'   = xs
        | otherwise = (a', b') : delete a xs
  
  envWithPathOverride :: [FilePath] -> IO (Maybe [(String, String)])
  envWithPathOverride []            = return Nothing
  envWithPathOverride extraPathDirs = do
      env <- getEnvironment
      let path  = fromMaybe "" (lookup "PATH" env)
          path' = intercalate [searchPathSeparator]
                    (extraPathDirs ++ splitSearchPath path)
          env'  = ("PATH", path') : filter (\(var, _) -> var /= "PATH") env
      return (Just env')
  
  -- | Writes a file atomically.
  --
  -- The file is either written successfully or an IO exception is raised and
  -- the original file is left unchanged.
  --
  -- On windows it is not possible to delete a file that is open by a process.
  -- This case will give an IO exception but the atomic property is not affected.
  --
  -- Returns the hash of the file; we are careful not to force the entire input
  -- bytestring into memory (we compute the hash as we write the file).
  writeFileAtomic :: FilePath -> BSL.ByteString -> IO MD5Digest
  writeFileAtomic targetPath content = do
    let (targetDir, targetFile) = splitFileName targetPath
    createDirectoryIfMissing True targetDir
    Ex.bracketOnError
      (openBinaryTempFile targetDir $ targetFile <.> "tmp")
      (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
      (\(tmpPath, handle) -> do
          let bits :: Tagged MD5Digest BitLength ; bits = blockLength
          hash <- go handle initialCtx $ makeBlocks (untag bits `div` 8) content
          hClose handle
          renameFile tmpPath targetPath
          return hash)
    where
      go :: Handle -> MD5Context -> [BSS.ByteString] -> IO MD5Digest
      go _ _   []       = error "Bug in makeBlocks"
      go h ctx [bs]     = BSS.hPut h bs >> return (finalize ctx bs)
      go h ctx (bs:bss) = BSS.hPut h bs >> go h (updateCtx ctx bs) bss
  
  -- | @makeBlocks n@ splits a bytestring into blocks with a size that is a
  -- multiple of 'n', with one left-over smaller bytestring at the end.
  --
  -- Based from the (unexported) 'makeBlocks' in the crypto-api package, but
  -- we are careful to be as lazy as possible (the first -- block can be returned
  -- before the entire input bytestring is forced)
  makeBlocks :: Int -> BSL.ByteString -> [BSS.ByteString]
  makeBlocks n = go . BSL.toChunks
    where
      go [] = [BSS.empty]
      go (bs:bss)
        | BSS.length bs >= n =
            let l = BSS.length bs - (BSS.length bs `rem` n)
                (bsInit, bsTail) = BSS.splitAt l bs
            in bsInit : go (bsTail : bss)
        | otherwise =
            case bss of
              []         -> [bs]
              (bs':bss') -> go (BSS.append bs bs' : bss')
  
  -- | First restore the environment to the specified initial environment, then
  -- apply the given overrides
  setupEnv :: [(String, String)] -> [(String, Maybe String)] -> IO ()
  setupEnv initEnv overrides = do
    -- Delete everything in the current environment
    curEnv <- getEnvironment
    forM_ curEnv $ \(var, _val) -> unsetEnv var
  
    -- Restore initial environment
    forM_ initEnv $ \(var, val) -> setEnv var val
    -- previously used the Posix setEnv, which had an explicit flag for overwrites (set to True)
    -- not sure about the behavior of the portable version
  
    -- Apply overrides
    forM_ overrides $ \(var, mVal) ->
      case mVal of
        Just val -> setEnv var val -- see comment about setEnv above
        Nothing  -> unsetEnv var
  
  relInclToOpts :: FilePath -> [FilePath] -> [String]
  relInclToOpts sourcesDir relIncl =
     ["-i"]  -- reset to empty
     ++ map (\path -> "-i" ++ sourcesDir </> path) relIncl
  
  parseProgressMessage :: Text -> Either String (Int, Int, Text)
  parseProgressMessage = Att.parseOnly parser
    where
      parser :: Att.Parser (Int, Int, Text)
      parser = do
        _    <- Att.char '['                ; Att.skipSpace
        step <- Att.decimal                 ; Att.skipSpace
        _    <- Att.string (Text.pack "of") ; Att.skipSpace
        numS <- Att.decimal                 ; Att.skipSpace
        _    <- Att.char ']'                ; Att.skipSpace
        rest <- parseCompiling `mplus` Att.takeText
        return (step, numS, rest)
  
      parseCompiling :: Att.Parser Text
      parseCompiling = do
        compiling <- Att.string (Text.pack "Compiling") ; Att.skipSpace
        _         <- parseTH                            ; Att.skipSpace
        modName   <- Att.takeTill isSpace
        return $ Text.concat [compiling, Text.pack " ", modName]
  
      parseTH :: Att.Parser ()
      parseTH = Att.option () $ void $ Att.string (Text.pack "[TH]")
  
  -- | Ignore "does not exist" exception
  ignoreDoesNotExist :: IO () -> IO ()
  ignoreDoesNotExist = Ex.handle $ \e ->
    if isDoesNotExistError e then return ()
                             else Ex.throwIO e
  
  -- | Define interruptiple operations
  --
  -- (TODO: Stick in reference to blog post)
  interruptible :: IO a -> IO a
  interruptible act = do
    st <- Ex.getMaskingState
    case st of
      Ex.Unmasked              -> act
      Ex.MaskedInterruptible   -> unsafeUnmask act
      Ex.MaskedUninterruptible -> act
  
  {------------------------------------------------------------------------------
    Simple diffs
  ------------------------------------------------------------------------------}
  
  data Diff a = Keep | Remove | Insert a
    deriving (Show, Functor, Generic)
  
  instance Binary a => Binary (Diff a) where
    put Keep       = Bin.putWord8 0
    put Remove     = Bin.putWord8 1
    put (Insert a) = Bin.putWord8 2 >> Bin.put a
  
    get = do
      header <- Bin.getWord8
      case header of
        0 -> return Keep
        1 -> return Remove
        2 -> Insert <$> Bin.get
        _ -> fail "Diff.get: invalid header"
  
  instance PrettyVal a => PrettyVal (Diff a) -- relies on Generics
  
  applyMapDiff :: forall k v. Ord k
               => Strict (Map k) (Diff v)
               -> Strict (Map k) v -> Strict (Map k) v
  applyMapDiff diff = foldr (.) id (map aux $ StrictMap.toList diff)
    where
      aux :: (k, Diff v) -> Strict (Map k) v -> Strict (Map k) v
      aux (_, Keep)     = id
      aux (k, Remove)   = StrictMap.delete k
      aux (k, Insert x) = StrictMap.insert k x
  
  {-------------------------------------------------------------------------------
    Manipulations with stdout and stderr.
  -------------------------------------------------------------------------------}
  swizzleStdout :: FileDescriptor -> IO a -> IO a
  swizzleStdout = swizzleHandle (stdout, stdOutput)
  
  swizzleStderr :: FileDescriptor -> IO a -> IO a
  swizzleStderr = swizzleHandle (stderr, stdError)
  
  swizzleHandle :: (Handle, FileDescriptor) -> FileDescriptor -> IO a -> IO a
  swizzleHandle (targetHandle, targetFd) fd act =
      Ex.bracket swizzle unswizzle (\_ -> act)
    where
      swizzle :: IO FileDescriptor
      swizzle = do
        -- Flush existing handles
        hFlush targetHandle
        fflush nullPtr
  
        -- Backup stdout, then replace stdout with the given fd
        backup <- dup targetFd
        _ <- dupTo fd targetFd
  
        return backup
  
      unswizzle :: FileDescriptor -> IO ()
      unswizzle backup = do
        -- Flush handles again
        hFlush targetHandle
        fflush nullPtr
  
        -- Restore stdout
        _ <- dupTo backup targetFd
        closeFd backup
  
  redirectStderr :: FilePath -> IO a -> IO a
  redirectStderr fp act = do
    Ex.bracket (openWritableFile fp)
               closeFd $ \errorLogFd ->
      swizzleStderr errorLogFd $
        act
  
  captureOutput :: IO a -> IO (String, a)
  captureOutput act = do
    withSystemTempFile "suppressed" $ \fp handle -> do
      fd <- handleToFd handle
      a  <- swizzleStdout fd . swizzleStderr fd $ act
      closeFd fd
      suppressed <- readFile fp
      return (suppressed, a)
  
  {-------------------------------------------------------------------------------
    Non-Unix compatibility
  -------------------------------------------------------------------------------}
  
  -- A data type for RPC communication when trying to run a @ReqRun@ value on the server
  -- Encoding the possibility that the action is not supported
  data ReqRunRpc = ReqRunConversation Pid WriteChannel ReadChannel FilePath
                 | ReqRunUnsupported String
                 deriving (Generic, Typeable)
  
  instance Binary ReqRunRpc
  
  newtype UnsupportedOnNonUnix = UnsupportedOnNonUnix String
      deriving (Typeable, Show)
  instance Exception UnsupportedOnNonUnix
  
  {-------------------------------------------------------------------------------
    Orphans
  -------------------------------------------------------------------------------}
  
  #if !MIN_VERSION_text(1,2,1)
  instance Binary Text where
    get   = do units <- Bin.get
               Bin.readNWith (units * 2) $ \ptr ->
                 Text.fromPtr (castPtr ptr) (fromIntegral units)
  
    put t = do put (Text.lengthWord16 t)
               Bin.putBuilder $
                 Bin.writeN (Text.lengthWord16 t * 2)
                            (\p -> Text.unsafeCopyToPtr t (castPtr p))
  #endif
  
  deriving instance Binary CPid
  