    {-# LANGUAGE BlockArguments            #-}
    {-# LANGUAGE CPP                       #-}
    {-# LANGUAGE DeriveAnyClass            #-}
    {-# LANGUAGE DeriveGeneric             #-}
    {-# LANGUAGE ExistentialQuantification #-}
    {-# LANGUAGE LambdaCase                #-}
    {-# LANGUAGE RecordWildCards           #-}
    {-# LANGUAGE ScopedTypeVariables       #-}
    {-# LANGUAGE TypeApplications          #-}

    -- | The implementation of loading and calling external functions from shared
    -- libraries.
    module Cryptol.Backend.FFI
      ( ForeignSrc
      , getForeignSrcPath
      , loadForeignSrc
      , unloadForeignSrc
      , foreignLibPath
    #ifdef FFI_ENABLED
      , ForeignImpl
      , loadForeignImpl
      , FFIArg
      , FFIRet
      , SomeFFIArg (..)
      , callForeignImpl
    #endif
      )
      where

    import           Control.DeepSeq

    import           Cryptol.Backend.FFI.Error

    #ifdef FFI_ENABLED

    import           Control.Concurrent.MVar
    import           Control.Exception
    import           Control.Monad
    import           Data.Bifunctor
    import           Data.Word
    import           Foreign                    hiding (newForeignPtr)
    import           Foreign.C.Types
    import           Foreign.Concurrent
    import           Foreign.LibFFI
    import           System.FilePath            ((-<.>))
    import           System.Directory(doesFileExist)
    import           System.IO.Error
    import           System.Info(os)

    #if defined(mingw32_HOST_OS)
    import           System.Win32.DLL
    #else
    import           System.Posix.DynamicLinker
    #endif

    import           Cryptol.Utils.Panic

    #else

    import           GHC.Generics

    #endif

    #ifdef FFI_ENABLED

    -- | A source from which we can retrieve implementations of foreign functions.
    data ForeignSrc = ForeignSrc
      { -- | The file path of the 'ForeignSrc'.
        ForeignSrc -> FilePath
    foreignSrcPath   :: FilePath
        -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the
        -- finalizer calls 'dlclose' when the library is no longer needed. We keep
        -- references to the 'ForeignPtr' in each foreign function that is in the
        -- evaluation environment, so that the shared library will stay open as long
        -- as there are references to it.
      , ForeignSrc -> ForeignPtr ()
    foreignSrcFPtr   :: ForeignPtr ()
        -- | We support explicit unloading of the shared library so we keep track of
        -- if it has already been unloaded, and if so the finalizer does nothing.
        -- This is updated atomically when the library is unloaded.
      , ForeignSrc -> MVar Bool
    foreignSrcLoaded :: MVar Bool }

    instance Show ForeignSrc where
      show :: ForeignSrc -> FilePath
    show = ForeignPtr () -> FilePath
    forall a. Show a => a -> FilePath
    show (ForeignPtr () -> FilePath)
    -> (ForeignSrc -> ForeignPtr ()) -> ForeignSrc -> FilePath
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ForeignSrc -> ForeignPtr ()
    foreignSrcFPtr

    instance NFData ForeignSrc where
      rnf :: ForeignSrc -> ()
    rnf ForeignSrc {FilePath
    ForeignPtr ()
    MVar Bool
    foreignSrcPath :: ForeignSrc -> FilePath
    foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
    foreignSrcLoaded :: ForeignSrc -> MVar Bool
    foreignSrcPath :: FilePath
    foreignSrcFPtr :: ForeignPtr ()
    foreignSrcLoaded :: MVar Bool
    ..} = ForeignPtr ()
    foreignSrcFPtr ForeignPtr () -> () -> ()
    forall a b. a -> b -> b
    `seq` MVar Bool
    foreignSrcLoaded MVar Bool -> () -> ()
    forall a b. NFData a => a -> b -> b
    `deepseq` ()

    -- | Get the file path of the 'ForeignSrc'.
    getForeignSrcPath :: ForeignSrc -> Maybe FilePath
    getForeignSrcPath :: ForeignSrc -> Maybe FilePath
    getForeignSrcPath = FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just (FilePath -> Maybe FilePath)
    -> (ForeignSrc -> FilePath) -> ForeignSrc -> Maybe FilePath
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ForeignSrc -> FilePath
    foreignSrcPath

    -- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of
    -- the shared library that we try to load is the same as the Cryptol file path
    -- except with a platform specific extension.
    loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
    loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
    loadForeignSrc = FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
    loadForeignLib (FilePath -> IO (Either FFILoadError (FilePath, Ptr ())))
    -> (Either FFILoadError (FilePath, Ptr ())
        -> IO (Either FFILoadError ForeignSrc))
    -> FilePath
    -> IO (Either FFILoadError ForeignSrc)
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> ((FilePath, Ptr ()) -> IO ForeignSrc)
    -> Either FFILoadError (FilePath, Ptr ())
    -> IO (Either FFILoadError ForeignSrc)
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Either FFILoadError a -> f (Either FFILoadError b)
    traverse \(FilePath
    foreignSrcPath, Ptr ()
    ptr) -> do
      MVar Bool
    foreignSrcLoaded <- Bool -> IO (MVar Bool)
    forall a. a -> IO (MVar a)
    newMVar Bool
    True
      ForeignPtr ()
    foreignSrcFPtr <- Ptr () -> IO () -> IO (ForeignPtr ())
    forall a. Ptr a -> IO () -> IO (ForeignPtr a)
    newForeignPtr Ptr ()
    ptr (MVar Bool -> Ptr () -> IO ()
    unloadForeignSrc' MVar Bool
    foreignSrcLoaded Ptr ()
    ptr)
      ForeignSrc -> IO ForeignSrc
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ForeignSrc {FilePath
    ForeignPtr ()
    MVar Bool
    foreignSrcPath :: FilePath
    foreignSrcFPtr :: ForeignPtr ()
    foreignSrcLoaded :: MVar Bool
    foreignSrcPath :: FilePath
    foreignSrcLoaded :: MVar Bool
    foreignSrcFPtr :: ForeignPtr ()
    ..}

    -- | Given the path to a Cryptol module, compute the location of
    -- the shared library we'd like to load.
    foreignLibPath :: FilePath -> IO (Maybe FilePath)
    foreignLibPath :: FilePath -> IO (Maybe FilePath)
    foreignLibPath FilePath
    path =
      [FilePath] -> IO (Maybe FilePath)
    search
        case FilePath
    os of
          FilePath
    "mingw32" -> [FilePath
    "dll"]
          FilePath
    "darwin"  -> [FilePath
    "dylib",FilePath
    "so"]
          FilePath
    _         -> [FilePath
    "so"]

      where
      search :: [FilePath] -> IO (Maybe FilePath)
    search [FilePath]
    es =
        case [FilePath]
    es of
          [] -> Maybe FilePath -> IO (Maybe FilePath)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe FilePath
    forall a. Maybe a
    Nothing
          FilePath
    e : [FilePath]
    more ->
            do let p :: FilePath
    p = FilePath
    path FilePath -> ShowS
    -<.> FilePath
    e
               Bool
    yes <- FilePath -> IO Bool
    doesFileExist FilePath
    p
               if Bool
    yes then Maybe FilePath -> IO (Maybe FilePath)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just FilePath
    p) else [FilePath] -> IO (Maybe FilePath)
    search [FilePath]
    more

    loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
    loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
    loadForeignLib FilePath
    path =
      do Maybe FilePath
    mb <- FilePath -> IO (Maybe FilePath)
    foreignLibPath FilePath
    path
         case Maybe FilePath
    mb of
           Maybe FilePath
    Nothing      -> Either FFILoadError (FilePath, Ptr ())
    -> IO (Either FFILoadError (FilePath, Ptr ()))
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (FFILoadError -> Either FFILoadError (FilePath, Ptr ())
    forall a b. a -> Either a b
    Left (FilePath -> FilePath -> FFILoadError
    CantLoadFFISrc FilePath
    path FilePath
    "File not found"))
           Just FilePath
    libPath -> (FilePath -> FFILoadError)
    -> IO (FilePath, Ptr ())
    -> IO (Either FFILoadError (FilePath, Ptr ()))
    forall a.
    (FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
    tryLoad (FilePath -> FilePath -> FFILoadError
    CantLoadFFISrc FilePath
    path) (FilePath -> IO (FilePath, Ptr ())
    open FilePath
    libPath)

      where open :: FilePath -> IO (FilePath, Ptr ())
    open FilePath
    libPath = do
    #if defined(mingw32_HOST_OS)
              ptr <- loadLibrary libPath
    #else
              -- RTLD_NOW so we can make sure that the symbols actually exist at
              -- module loading time
              Ptr ()
    ptr <- DL -> Ptr ()
    undl (DL -> Ptr ()) -> IO DL -> IO (Ptr ())
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> [RTLDFlags] -> IO DL
    dlopen FilePath
    libPath [RTLDFlags
    RTLD_NOW]
    #endif
              (FilePath, Ptr ()) -> IO (FilePath, Ptr ())
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (FilePath
    libPath, Ptr ()
    ptr)

    -- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the
    -- garbage collector to do it. This can be useful if you want to immediately
    -- load the same library again to pick up new changes.
    --
    -- The 'ForeignSrc' __must not__ be used in any way after this is called,
    -- including calling 'ForeignImpl's loaded from it.
    unloadForeignSrc :: ForeignSrc -> IO ()
    unloadForeignSrc :: ForeignSrc -> IO ()
    unloadForeignSrc ForeignSrc {FilePath
    ForeignPtr ()
    MVar Bool
    foreignSrcPath :: ForeignSrc -> FilePath
    foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
    foreignSrcLoaded :: ForeignSrc -> MVar Bool
    foreignSrcPath :: FilePath
    foreignSrcFPtr :: ForeignPtr ()
    foreignSrcLoaded :: MVar Bool
    ..} = ForeignPtr () -> (Ptr () -> IO ()) -> IO ()
    forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
    withForeignPtr ForeignPtr ()
    foreignSrcFPtr ((Ptr () -> IO ()) -> IO ()) -> (Ptr () -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $
      MVar Bool -> Ptr () -> IO ()
    unloadForeignSrc' MVar Bool
    foreignSrcLoaded

    unloadForeignSrc' :: MVar Bool -> Ptr () -> IO ()
    unloadForeignSrc' :: MVar Bool -> Ptr () -> IO ()
    unloadForeignSrc' MVar Bool
    loaded Ptr ()
    lib = MVar Bool -> (Bool -> IO Bool) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar Bool
    loaded \Bool
    l -> do
      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    l (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Ptr () -> IO ()
    unloadForeignLib Ptr ()
    lib
      Bool -> IO Bool
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False

    unloadForeignLib :: Ptr () -> IO ()
    #if defined(mingw32_HOST_OS)
    unloadForeignLib = freeLibrary
    #else
    unloadForeignLib :: Ptr () -> IO ()
    unloadForeignLib = DL -> IO ()
    dlclose (DL -> IO ()) -> (Ptr () -> DL) -> Ptr () -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ptr () -> DL
    DLHandle
    #endif

    withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a
    withForeignSrc :: forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
    withForeignSrc ForeignSrc {FilePath
    ForeignPtr ()
    MVar Bool
    foreignSrcPath :: ForeignSrc -> FilePath
    foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
    foreignSrcLoaded :: ForeignSrc -> MVar Bool
    foreignSrcPath :: FilePath
    foreignSrcFPtr :: ForeignPtr ()
    foreignSrcLoaded :: MVar Bool
    ..} Ptr () -> IO a
    f = MVar Bool -> (Bool -> IO a) -> IO a
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar MVar Bool
    foreignSrcLoaded
      \case
        Bool
    True -> ForeignPtr () -> (Ptr () -> IO a) -> IO a
    forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
    withForeignPtr ForeignPtr ()
    foreignSrcFPtr Ptr () -> IO a
    f
        Bool
    False ->
          FilePath -> [FilePath] -> IO a
    forall a. HasCallStack => FilePath -> [FilePath] -> a
    panic FilePath
    "[FFI] withForeignSrc" [FilePath
    "Use of foreign library after unload"]

    -- | An implementation of a foreign function.
    data ForeignImpl = ForeignImpl
      { ForeignImpl -> FunPtr ()
    foreignImplFun :: FunPtr ()
        -- | We don't need this to call the function but we want to keep the library
        -- around as long as we still have a function from it so that it isn't
        -- unloaded too early.
      , ForeignImpl -> ForeignSrc
    foreignImplSrc :: ForeignSrc
      }

    -- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'.
    loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl)
    loadForeignImpl :: ForeignSrc -> FilePath -> IO (Either FFILoadError ForeignImpl)
    loadForeignImpl ForeignSrc
    foreignImplSrc FilePath
    name =
      ForeignSrc
    -> (Ptr () -> IO (Either FFILoadError ForeignImpl))
    -> IO (Either FFILoadError ForeignImpl)
    forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
    withForeignSrc ForeignSrc
    foreignImplSrc \Ptr ()
    lib ->
        (FilePath -> FFILoadError)
    -> IO ForeignImpl -> IO (Either FFILoadError ForeignImpl)
    forall a.
    (FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
    tryLoad (FilePath -> FilePath -> FFILoadError
    CantLoadFFIImpl FilePath
    name) do
          FunPtr ()
    foreignImplFun <- Ptr () -> FilePath -> IO (FunPtr ())
    loadForeignFunPtr Ptr ()
    lib FilePath
    name
          ForeignImpl -> IO ForeignImpl
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ForeignImpl {FunPtr ()
    ForeignSrc
    foreignImplFun :: FunPtr ()
    foreignImplSrc :: ForeignSrc
    foreignImplSrc :: ForeignSrc
    foreignImplFun :: FunPtr ()
    ..}

    loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ())
    #if defined(mingw32_HOST_OS)
    loadForeignFunPtr source symbol = do
      addr <- getProcAddress source symbol
      pure $ castPtrToFunPtr addr
    #else
    loadForeignFunPtr :: Ptr () -> FilePath -> IO (FunPtr ())
    loadForeignFunPtr = DL -> FilePath -> IO (FunPtr ())
    forall a. DL -> FilePath -> IO (FunPtr a)
    dlsym (DL -> FilePath -> IO (FunPtr ()))
    -> (Ptr () -> DL) -> Ptr () -> FilePath -> IO (FunPtr ())
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ptr () -> DL
    DLHandle
    #endif

    tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
    tryLoad :: forall a.
    (FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
    tryLoad FilePath -> FFILoadError
    err = (Either IOError a -> Either FFILoadError a)
    -> IO (Either IOError a) -> IO (Either FFILoadError a)
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((IOError -> FFILoadError)
    -> Either IOError a -> Either FFILoadError a
    forall a b c. (a -> b) -> Either a c -> Either b c
    forall (p :: * -> * -> *) a b c.
    Bifunctor p =>
    (a -> b) -> p a c -> p b c
    first ((IOError -> FFILoadError)
     -> Either IOError a -> Either FFILoadError a)
    -> (IOError -> FFILoadError)
    -> Either IOError a
    -> Either FFILoadError a
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FFILoadError
    err (FilePath -> FFILoadError)
    -> (IOError -> FilePath) -> IOError -> FFILoadError
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IOError -> FilePath
    forall e. Exception e => e -> FilePath
    displayException) (IO (Either IOError a) -> IO (Either FFILoadError a))
    -> (IO a -> IO (Either IOError a))
    -> IO a
    -> IO (Either FFILoadError a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IO a -> IO (Either IOError a)
    forall a. IO a -> IO (Either IOError a)
    tryIOError

    -- | Types which can be converted into libffi arguments.
    --
    -- The Storable constraint is so that we can put them in arrays.
    class Storable a => FFIArg a where
      ffiArg :: a -> Arg

    instance FFIArg Word8 where
      ffiArg :: Word8 -> Arg
    ffiArg = Word8 -> Arg
    argWord8

    instance FFIArg Word16 where
      ffiArg :: Word16 -> Arg
    ffiArg = Word16 -> Arg
    argWord16

    instance FFIArg Word32 where
      ffiArg :: Word32 -> Arg
    ffiArg = Word32 -> Arg
    argWord32

    instance FFIArg Word64 where
      ffiArg :: Word64 -> Arg
    ffiArg = Word64 -> Arg
    argWord64

    instance FFIArg CFloat where
      ffiArg :: CFloat -> Arg
    ffiArg = CFloat -> Arg
    argCFloat

    instance FFIArg CDouble where
      ffiArg :: CDouble -> Arg
    ffiArg = CDouble -> Arg
    argCDouble

    instance FFIArg (Ptr a) where
      ffiArg :: Ptr a -> Arg
    ffiArg = Ptr a -> Arg
    forall a. Ptr a -> Arg
    argPtr

    instance FFIArg CSize where
      ffiArg :: CSize -> Arg
    ffiArg = CSize -> Arg
    argCSize

    -- | Types which can be returned from libffi.
    --
    -- The Storable constraint is so that we can put them in arrays.
    class Storable a => FFIRet a where
      ffiRet :: RetType a

    instance FFIRet Word8 where
      ffiRet :: RetType Word8
    ffiRet = RetType Word8
    retWord8

    instance FFIRet Word16 where
      ffiRet :: RetType Word16
    ffiRet = RetType Word16
    retWord16

    instance FFIRet Word32 where
      ffiRet :: RetType Word32
    ffiRet = RetType Word32
    retWord32

    instance FFIRet Word64 where
      ffiRet :: RetType Word64
    ffiRet = RetType Word64
    retWord64

    instance FFIRet CFloat where
      ffiRet :: RetType CFloat
    ffiRet = RetType CFloat
    retCFloat

    instance FFIRet CDouble where
      ffiRet :: RetType CDouble
    ffiRet = RetType CDouble
    retCDouble

    instance FFIRet () where
      ffiRet :: RetType ()
    ffiRet = RetType ()
    retVoid

    -- | Existential wrapper around a 'FFIArg'.
    data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a

    -- | Call a 'ForeignImpl' with the given arguments. The type parameter decides
    -- how the return value should be converted into a Haskell value.
    callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
    callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
    callForeignImpl ForeignImpl {FunPtr ()
    ForeignSrc
    foreignImplFun :: ForeignImpl -> FunPtr ()
    foreignImplSrc :: ForeignImpl -> ForeignSrc
    foreignImplFun :: FunPtr ()
    foreignImplSrc :: ForeignSrc
    ..} [SomeFFIArg]
    xs = ForeignSrc -> (Ptr () -> IO a) -> IO a
    forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
    withForeignSrc ForeignSrc
    foreignImplSrc \Ptr ()
    _ ->
      FunPtr () -> RetType a -> [Arg] -> IO a
    forall a b. FunPtr a -> RetType b -> [Arg] -> IO b
    callFFI FunPtr ()
    foreignImplFun (forall a. FFIRet a => RetType a
    ffiRet @a) ([Arg] -> IO a) -> [Arg] -> IO a
    forall a b. (a -> b) -> a -> b
    $ (SomeFFIArg -> Arg) -> [SomeFFIArg] -> [Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map SomeFFIArg -> Arg
    toArg [SomeFFIArg]
    xs
      where toArg :: SomeFFIArg -> Arg
    toArg (SomeFFIArg a
    x) = a -> Arg
    forall a. FFIArg a => a -> Arg
    ffiArg a
    x

    #else

    data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData)

    getForeignSrcPath :: ForeignSrc -> Maybe FilePath
    getForeignSrcPath _ = Nothing

    loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
    loadForeignSrc _ = pure $ Right ForeignSrc

    unloadForeignSrc :: ForeignSrc -> IO ()
    unloadForeignSrc _ = pure ()

    #endif