{-# LANGUAGE BlockArguments            #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# 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.Maybe
import           Data.Word
import           Foreign                    hiding (newForeignPtr)
import           Foreign.C.Types
import           Foreign.Concurrent
import           Foreign.LibFFI
import           System.Directory           (canonicalizePath, doesFileExist)
import           System.FilePath            ((-<.>))
import           System.Info                (os)
import           System.IO.Error

#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. If FFI is supported, returns the location and
-- whether or not it actually exists on disk. Otherwise, returns Nothing.
foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool))
foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool))
foreignLibPath FilePath
path = do
  FilePath
path' <- FilePath -> IO FilePath
canonicalizePath FilePath
path
  let libPaths :: [FilePath]
libPaths = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
path' FilePath -> ShowS
-<.>) [FilePath]
exts
      search :: [FilePath] -> IO (Maybe (FilePath, Bool))
search [FilePath]
ps =
        case [FilePath]
ps of
          [] -> Maybe (FilePath, Bool) -> IO (Maybe (FilePath, Bool))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((, Bool
False) (FilePath -> (FilePath, Bool))
-> Maybe FilePath -> Maybe (FilePath, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe [FilePath]
libPaths)
          FilePath
p : [FilePath]
more -> do
            Bool
yes <- FilePath -> IO Bool
doesFileExist FilePath
p
            if Bool
yes then Maybe (FilePath, Bool) -> IO (Maybe (FilePath, Bool))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FilePath, Bool) -> Maybe (FilePath, Bool)
forall a. a -> Maybe a
Just (FilePath
p, Bool
True)) else [FilePath] -> IO (Maybe (FilePath, Bool))
search [FilePath]
more
  [FilePath] -> IO (Maybe (FilePath, Bool))
search [FilePath]
libPaths
  where
  exts :: [FilePath]
exts =
    case FilePath
os of
      FilePath
"mingw32" -> [FilePath
"dll"]
      FilePath
"darwin"  -> [FilePath
"dylib",FilePath
"so"]
      FilePath
_         -> [FilePath
"so"]

loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
loadForeignLib FilePath
path =
  do Maybe (FilePath, Bool)
mb <- FilePath -> IO (Maybe (FilePath, Bool))
foreignLibPath FilePath
path
     case Maybe (FilePath, Bool)
mb of
       Just (FilePath
libPath, Bool
True) ->
         (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)
       Maybe (FilePath, Bool)
_ ->
         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"))

  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 ()

foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool))
foreignLibPath _ = pure Nothing

#endif