diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 1.1.1 + +- First release on Hackage, at the version of the SDK it belongs to. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,82 @@ +# KeyNub License Dongle — Haskell package + +```haskell +import KeyNub.LicDongle + +main :: IO () +main = withDongle open $ \d -> do -- first dongle, or openSerial "..." + _ <- verifyGenuine d -- throws unless genuine + secret <- withSession d $ -- closed on every exit path + appDecrypt d sealed -- <- build the licence check on this + ... +``` + +**Pure Haskell.** The package calls the SDK's flat companion API through +function pointers resolved at run time, so nothing is linked at build time, +there is no C to compile and nothing sits in the path of the check that a +customer could substitute. `base`, `bytestring`, `directory`, `filepath` and +the platform's loader package (`unix`, or `Win32` on Windows) are the +dependencies. GHC 9.4 or later, on Windows, Linux and macOS. + +## Setup + +``` +cabal install keynub-licdongle +``` + +or `keynub-licdongle` in `build-depends`. The package does not carry the +native library. Take `keynub_licdongle_flat` for your platform from the SDK's +[natives folder](https://github.com/AB-KeyNub/KeyNub-SDK/blob/master/NATIVES.md) +and either put it where the operating system finds libraries (next to the +executable, or on `PATH`, `LD_LIBRARY_PATH`, `DYLD_LIBRARY_PATH`), or name it +before the first call: + +```haskell +setLibraryPath "/opt/keynub/libkeynub_licdongle_flat.so" +``` + +`KEYNUB_LICDONGLE_FLAT_LIBRARY` in the environment does the same. In a clone +of the SDK repository the package finds `natives//` on its own, from +the working directory upwards, so the samples run with nothing set. A process +loads the library once; `loadedLibraryPath` tells which. On Linux, install the +udev rule described in +[`NATIVES.md`](https://github.com/AB-KeyNub/KeyNub-SDK/blob/master/NATIVES.md) +so the dongle is accessible without root. + +## Notes + +- Results are records (`Info`, `GenuineResult`, `Device`, `RecordInfo`); byte + data is `ByteString`. The package calls the SDK's flat API: integer handles + and caller-provided buffers, no C structures and no hand-written layouts. +- Failures throw `LicDongleError` with `errorStatus` (`NoDevice`, + `NotGenuine`, `AuthRequired`, ...), `errorCode`, `errorOperation` and + `errorDetail`; loading problems throw `LibraryError`. +- `isGenuine` is the non-throwing form for a gate and **fails closed**: every + failure gives `False`. +- `withDongle` and `withSession` are `bracket`s: the dongle and the session + are closed on every exit path, exceptions included. +- `eraseAllRecords` is deliberately separate from `eraseRecord`: an + accidentally empty name must not wipe the dongle. +- Records are transferred in one call; the flat API has no progress + reporting. + +> Read [`docs/integration-security.md`](https://github.com/AB-KeyNub/KeyNub-SDK/blob/master/docs/integration-security.md) +> before writing the check. `ok <- isGenuine d; unless ok exitFailure` is one +> conditional branch, and patching one of those in a release binary is a +> beginner exercise. Route something the program needs through `appEncrypt` and +> `appDecrypt`, so removing the check removes the data. + +## Tests + +`cabal test` runs without a dongle: it compiles a stand-in for the flat C API +(`bindings/flat/licd_flat.c` over `bindings/julia/test/stub/licd_stub.c`) with +the C compiler on the path and exercises every call against it. In a package +taken from Hackage the SDK sources are not present; point `KEYNUB_SDK_ROOT` at +a clone, or `KEYNUB_LICDONGLE_FLAT_LIBRARY` at a compiled stand-in. + +## Links + +- [KeyNub License Dongle for Haskell](https://www.keynub.com/developers/haskell/): the product, and how to + order one +- [Source, samples and issue tracker](https://github.com/AB-KeyNub/KeyNub-SDK) on GitHub +- [Native library for your platform](https://github.com/AB-KeyNub/KeyNub-SDK/blob/master/NATIVES.md) diff --git a/keynub-licdongle.cabal b/keynub-licdongle.cabal new file mode 100644 --- /dev/null +++ b/keynub-licdongle.cabal @@ -0,0 +1,55 @@ +cabal-version: 3.0 +name: keynub-licdongle +version: 1.1.1 +synopsis: Client for the KeyNub USB license dongle +description: + Verify that a KeyNub USB license dongle is genuine, read and write the + license records it stores, use its hardware counters and encrypt data so + that only a dongle can decrypt it. Pure Haskell over the SDK's flat C API: + the native library is loaded at run time, nothing is linked. +homepage: https://www.keynub.com/developers/haskell/ +bug-reports: https://github.com/AB-KeyNub/KeyNub-SDK/issues +license: Apache-2.0 +license-file: LICENSE +author: KeyNub +maintainer: info@keynub.com +copyright: 2026 KeyNub +category: Hardware +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 9.12.4 + +source-repository head + type: git + location: https://github.com/AB-KeyNub/KeyNub-SDK.git + subdir: bindings/haskell + +common shared + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.14 && < 5 + +library + import: shared + hs-source-dirs: src + exposed-modules: KeyNub.LicDongle + KeyNub.LicDongle.Library + build-depends: bytestring >= 0.10 && < 0.13, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6 + if os(windows) + build-depends: Win32 >= 2.6 && < 2.15 + else + build-depends: unix >= 2.7 && < 2.9 + +test-suite stub + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: StubTest.hs + build-depends: keynub-licdongle, + bytestring, + directory, + filepath, + process >= 1.6 && < 1.7 diff --git a/src/KeyNub/LicDongle.hs b/src/KeyNub/LicDongle.hs new file mode 100644 --- /dev/null +++ b/src/KeyNub/LicDongle.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | KeyNub License Dongle for Haskell. +-- +-- Calls the SDK's flat companion API (@keynub_licdongle_flat@) through +-- function pointers resolved at run time, so nothing is linked at build time +-- and the package is pure Haskell. Handles are 'Dongle' values; byte data is +-- 'ByteString'; every failure is a 'LicDongleError' exception carrying the +-- library's status code, the operation and its diagnostic detail. +-- +-- @ +-- import KeyNub.LicDongle +-- +-- main = withDongle open $ \\d -> do +-- _ <- verifyGenuine d -- throws unless genuine +-- secret <- withSession d $ appDecrypt d sealed -- build the licence check on this +-- ... +-- @ +module KeyNub.LicDongle + ( -- * The native library + libraryVersion + , libraryPath + , loadedLibraryPath + , setLibraryPath + , statusText + -- * Failures + , Status(..) + , statusFromCode + , LicDongleError(..) + , LibraryError(..) + -- * Dongles + , Device(..) + , devices + , Dongle + , open + , openSerial + , openPath + , close + , withDongle + , serial + , Info(..) + , info + , lastErrorDetail + -- * Authenticity + , GenuineResult(..) + , verifyGenuine + , isGenuine + , setTrustRoot + -- * Session + , sessionOpen + , sessionClose + , withSession + , authorizeWrite + , rotateWriteKey + -- * Records + , RecordInfo(..) + , records + , readRecord + , writeRecord + , eraseRecord + , eraseAllRecords + -- * Counters + , readCounter + , incrementCounter + -- * Application data + , Scope(..) + , appEncrypt + , appDecrypt + ) where + +import Control.Exception (Exception(..), SomeException, bracket, bracket_, catch, throwIO) +import Control.Monad (forM, when) +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Word (Word8) +import Foreign.C.String (CString, peekCString, withCString) +import Foreign.C.Types (CInt(..)) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (advancePtr, allocaArray, peekArray) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (peek, poke, pokeByteOff) + +import KeyNub.LicDongle.Library + +-- | The library's status codes, by name. +data Status + = InvalidArg | NoDevice | AccessDenied | IOFailure | Timeout | ProtocolError + | NotGenuine | CertInvalid | SessionExpired | TagMismatch | Range | StorageFull + | Busy | NotFound | AuthRequired | FirmwareIncompatible | SdkTooOld | Cancelled + | NotImplemented | Internal + | Unknown Int -- ^ a code this binding does not know + deriving (Eq, Show) + +-- | The 'Status' for a raw status code. +statusFromCode :: Int -> Status +statusFromCode c = case c of + -1 -> InvalidArg; -2 -> NoDevice; -3 -> AccessDenied; -4 -> IOFailure + -5 -> Timeout; -6 -> ProtocolError; -7 -> NotGenuine; -8 -> CertInvalid + -9 -> SessionExpired; -10 -> TagMismatch; -11 -> Range; -12 -> StorageFull + -13 -> Busy; -14 -> NotFound; -15 -> AuthRequired; -16 -> FirmwareIncompatible + -17 -> SdkTooOld; -18 -> Cancelled; -19 -> NotImplemented; -20 -> Internal + _ -> Unknown c + +-- | A failed call: the status, its raw code, the C function that failed and +-- the library's diagnostic detail for it (often empty). +data LicDongleError = LicDongleError + { errorStatus :: Status + , errorCode :: Int + , errorOperation :: String + , errorDetail :: String + } deriving (Eq, Show) + +instance Exception LicDongleError where + displayException e = + errorOperation e ++ ": " ++ show (errorStatus e) ++ " (" ++ show (errorCode e) ++ ")" + ++ (if null (errorDetail e) then "" else ": " ++ errorDetail e) + +-- | An attached dongle, as listed by 'devices'. +data Device = Device + { deviceSerial :: String -- ^ the serial, as hex + , devicePath :: String -- ^ the device path 'openPath' takes + } deriving (Eq, Show) + +-- | An open dongle. The library holds up to 32 at a time; release them with +-- 'close' or use 'withDongle'. +newtype Dongle = Dongle CInt + deriving (Eq, Show) + +-- | Plaintext device information, read without a session. +data Info = Info + { protocolVersion :: (Int, Int) + , firmwareVersion :: (Int, Int, Int) + , secureElementReady :: Bool + , provisioned :: Bool + , watchdogReboot :: Bool -- ^ the previous boot ended in a watchdog reset + , isolated :: Bool + , writeAuthRotated :: Bool -- ^ 'rotateWriteKey' has replaced the shipped write key + , dataCapacity :: Int -- ^ record storage, bytes + , dataFree :: Int + } deriving (Eq, Show) + +-- | What a genuine dongle proves: the serial from its certificate and the day +-- it was personalised (@YYYY-MM-DD@, or empty). +data GenuineResult = GenuineResult + { genuineSerial :: String + , provisionedDate :: String + } deriving (Eq, Show) + +-- | A record on the dongle. +data RecordInfo = RecordInfo + { recordName :: String + , recordSize :: Int + } deriving (Eq, Show) + +-- | Who can decrypt data sealed with 'appEncrypt'. +data Scope + = DeviceScope -- ^ only the dongle that sealed it + | DeveloperScope -- ^ any dongle issued to the same developer + deriving (Eq, Show) + +serialSize, dateSize, pathSize, errorSize :: Int +serialSize = 15 +dateSize = 11 +pathSize = 512 +errorSize = 256 + +rangeCode :: CInt +rangeCode = -11 + +-- Failure handling: every flat call returns 0 or a negative status. +check :: Maybe Dongle -> String -> CInt -> IO () +check h op rc + | rc == 0 = pure () + | otherwise = do + detail <- maybe (pure "") lastErrorDetail h + throwIO (LicDongleError (statusFromCode (fromIntegral rc)) (fromIntegral rc) op detail) + +withOutInt :: (Ptr CInt -> IO CInt) -> IO (CInt, CInt) +withOutInt f = alloca $ \p -> do + poke p 0 + rc <- f p + v <- peek p + pure (rc, v) + +-- A NUL-terminated string into a caller buffer of the given capacity. +readString :: Int -> (CString -> CInt -> IO CInt) -> IO (CInt, String) +readString cap f = allocaBytes cap $ \buf -> do + pokeByteOff buf 0 (0 :: Word8) + rc <- f buf (fromIntegral cap) + s <- if rc == 0 then peekCString buf else pure "" + pure (rc, s) + +-- Bytes of unknown length: ask with a capacity of 0, the library answers +-- Range and the size needed, then read into a buffer of that size. +readBytes :: Maybe Dongle -> String -> (Ptr Word8 -> CInt -> Ptr CInt -> IO CInt) -> IO ByteString +readBytes h op f = do + (rc0, need) <- withOutInt (f nullPtr 0) + if rc0 == 0 + then pure BS.empty + else if rc0 /= rangeCode + then check h op rc0 >> pure BS.empty + else allocaBytes (fromIntegral need) $ \buf -> do + (rc, len) <- withOutInt (f buf need) + check h op rc + BS.packCStringLen (castPtr buf, fromIntegral len) + +useBytes :: ByteString -> (Ptr Word8 -> CInt -> IO a) -> IO a +useBytes bs f = BS.useAsCStringLen bs $ \(p, n) -> f (castPtr p) (fromIntegral n) + +-- | @(major, minor, patch)@ of the loaded native library; loads it if no other +-- call has. +libraryVersion :: IO (Int, Int, Int) +libraryVersion = do + a <- api + allocaArray 3 $ \arr -> do + rc <- fVersion a arr (advancePtr arr 1) (advancePtr arr 2) + check Nothing "licdf_version" rc + [x, y, z] <- map fromIntegral <$> peekArray 3 arr + pure (x, y, z) + +-- | The library's text for a status code. +statusText :: Int -> IO String +statusText code = do + a <- api + snd <$> readString errorSize (fStrerror a (fromIntegral code)) + +-- | The library's diagnostic detail for the most recent failure on a dongle. +lastErrorDetail :: Dongle -> IO String +lastErrorDetail (Dongle h) = do + a <- api + snd <$> readString errorSize (fLastError a h) + +-- | The attached dongles. +devices :: IO [Device] +devices = do + a <- api + (rc, n) <- withOutInt (fDeviceCount a) + check Nothing "licdf_device_count" rc + forM [0 .. n - 1] $ \i -> do + (rc1, s) <- readString pathSize (fDeviceSerial a i) + check Nothing "licdf_device_serial" rc1 + (rc2, p) <- readString pathSize (fDevicePath a i) + check Nothing "licdf_device_path" rc2 + pure (Device s p) + +-- | Opens the first dongle. +open :: IO Dongle +open = openSerial "" + +-- | Opens the dongle with that serial (an empty serial means the first one). +openSerial :: String -> IO Dongle +openSerial s = do + a <- api + h <- withCString s (fOpen a) + handleOf "licdf_open" h + +-- | Opens the dongle at a device path from 'devices'. +openPath :: String -> IO Dongle +openPath p = do + a <- api + h <- withCString p (fOpenPath a) + handleOf "licdf_open_path" h + +handleOf :: String -> CInt -> IO Dongle +handleOf op h + | h > 0 = pure (Dongle h) + | otherwise = throwIO (LicDongleError (statusFromCode (fromIntegral h)) (fromIntegral h) op "") + +-- | Releases a dongle; its session ends with it. +close :: Dongle -> IO () +close (Dongle h) = do + a <- api + fClose a h >>= check Nothing "licdf_close" + +-- | Opens a dongle, runs the action, and closes the dongle on every exit path. +withDongle :: IO Dongle -> (Dongle -> IO a) -> IO a +withDongle acquire = bracket acquire close + +-- | The dongle's serial, as hex. +serial :: Dongle -> IO String +serial d@(Dongle h) = do + a <- api + (rc, s) <- readString serialSize (fGetSerial a h) + check (Just d) "licdf_get_serial" rc + pure s + +-- | Plaintext device information. +info :: Dongle -> IO Info +info d@(Dongle h) = do + a <- api + allocaArray 8 $ \arr -> do + let p i = advancePtr arr i + rc <- fGetInfo a h (p 0) (p 1) (p 2) (p 3) (p 4) (p 5) (p 6) (p 7) + check (Just d) "licdf_get_info" rc + v <- map fromIntegral <$> peekArray 8 arr + let flags = v !! 5 :: Int + flag b = flags .&. b /= 0 + pure Info + { protocolVersion = (v !! 0, v !! 1) + , firmwareVersion = (v !! 2, v !! 3, v !! 4) + , secureElementReady = flag 0x01 + , provisioned = flag 0x02 + , watchdogReboot = flag 0x04 + , isolated = flag 0x08 + , writeAuthRotated = flag 0x10 + , dataCapacity = v !! 6 + , dataFree = v !! 7 + } + +-- | Proves that the dongle is genuine: certificate chain to the trusted root +-- and a live challenge-response. Throws unless it is. +verifyGenuine :: Dongle -> IO GenuineResult +verifyGenuine d@(Dongle h) = do + a <- api + alloca $ \pg -> allocaBytes serialSize $ \ps -> allocaBytes dateSize $ \pd -> do + poke pg 0 + pokeByteOff ps 0 (0 :: Word8) + pokeByteOff pd 0 (0 :: Word8) + rc <- fVerifyGenuine a h pg ps (fromIntegral serialSize) pd (fromIntegral dateSize) + check (Just d) "licdf_verify_genuine" rc + g <- peek pg + when (g == 0) $ throwIO (LicDongleError NotGenuine (-7) "licdf_verify_genuine" "") + GenuineResult <$> peekCString ps <*> peekCString pd + +-- | 'True' only when the dongle proves genuine. Every failure, of any kind, +-- gives 'False'. +isGenuine :: Dongle -> IO Bool +isGenuine d = (verifyGenuine d >> pure True) `catch` \(_ :: SomeException) -> pure False + +-- | Replaces the CA root that 'verifyGenuine' checks against (a certificate in +-- DER form). Applications do not need this. +setTrustRoot :: Dongle -> ByteString -> IO () +setTrustRoot d@(Dongle h) der = do + a <- api + useBytes der (fSetTrustRoot a h) >>= check (Just d) "licdf_set_trust_root" + +-- | Opens the encrypted session that records, counters and application-data +-- encryption need. +sessionOpen :: Dongle -> IO () +sessionOpen d@(Dongle h) = do + a <- api + fSessionOpen a h >>= check (Just d) "licdf_session_open" + +-- | Ends the session; the write role ends with it. +sessionClose :: Dongle -> IO () +sessionClose d@(Dongle h) = do + a <- api + fSessionClose a h >>= check (Just d) "licdf_session_close" + +-- | Runs the action inside a session, closing it on every exit path. +withSession :: Dongle -> IO a -> IO a +withSession d = bracket_ (sessionOpen d) (sessionClose d) + +-- | Elevates the session to the write role with the dongle's write key, a +-- P-256 private key in PKCS#8 DER form. +authorizeWrite :: Dongle -> ByteString -> IO () +authorizeWrite d@(Dongle h) key = do + a <- api + useBytes key (fWriteAuth a h) >>= check (Just d) "licdf_write_auth" + +-- | Replaces the dongle's write key with the given one (P-256, PKCS#8 DER). +-- From the next session on, only that key elevates. Needs the write role. +rotateWriteKey :: Dongle -> ByteString -> IO () +rotateWriteKey d@(Dongle h) key = do + a <- api + useBytes key (fWriteAuthRotate a h) >>= check (Just d) "licdf_write_auth_rotate" + +-- | The records on the dongle. Needs a session. +records :: Dongle -> IO [RecordInfo] +records d@(Dongle h) = do + a <- api + (rc, n) <- withOutInt (fRecordCount a h) + check (Just d) "licdf_record_count" rc + forM [0 .. n - 1] $ \i -> allocaBytes pathSize $ \buf -> alloca $ \psz -> do + pokeByteOff buf 0 (0 :: Word8) + poke psz 0 + rc1 <- fRecordName a h i buf (fromIntegral pathSize) psz + check (Just d) "licdf_record_name" rc1 + RecordInfo <$> peekCString buf <*> (fromIntegral <$> peek psz) + +-- | Reads a record. Needs a session. +readRecord :: Dongle -> String -> IO ByteString +readRecord d@(Dongle h) name = do + a <- api + withCString name $ \cn -> readBytes (Just d) "licdf_record_read" (fRecordRead a h cn) + +-- | Replaces (or creates) a record. Needs the write role. +writeRecord :: Dongle -> String -> ByteString -> IO () +writeRecord d@(Dongle h) name bytes = do + a <- api + withCString name $ \cn -> useBytes bytes (fRecordWrite a h cn) >>= check (Just d) "licdf_record_write" + +-- | Erases one record. Needs the write role. An empty name is refused; use +-- 'eraseAllRecords' to erase everything. +eraseRecord :: Dongle -> String -> IO () +eraseRecord d@(Dongle h) name = do + a <- api + withCString name (fRecordErase a h) >>= check (Just d) "licdf_record_erase" + +-- | Erases every record. Needs the write role. +eraseAllRecords :: Dongle -> IO () +eraseAllRecords d@(Dongle h) = do + a <- api + fRecordEraseAll a h >>= check (Just d) "licdf_record_erase_all" + +-- | Reads a hardware monotonic counter (0 or 1). Needs a session. +readCounter :: Dongle -> Int -> IO Int +readCounter d@(Dongle h) i = do + a <- api + (rc, v) <- withOutInt (fCounterRead a h (fromIntegral i)) + check (Just d) "licdf_counter_read" rc + pure (fromIntegral v) + +-- | Increments a counter, irreversibly, and gives the new value. Needs the +-- write role. +incrementCounter :: Dongle -> Int -> IO Int +incrementCounter d@(Dongle h) i = do + a <- api + (rc, v) <- withOutInt (fCounterIncrement a h (fromIntegral i)) + check (Just d) "licdf_counter_increment" rc + pure (fromIntegral v) + +-- | Seals data so that only a dongle can open it. Needs a session. This is the +-- pair to build a licence check on: route something the program needs through +-- it, so that removing the check removes the data. +appEncrypt :: Dongle -> Scope -> ByteString -> IO ByteString +appEncrypt d@(Dongle h) scope plain = do + a <- api + let code = case scope of DeviceScope -> 0; DeveloperScope -> 1 + useBytes plain $ \pp n -> readBytes (Just d) "licdf_app_encrypt" (fAppEncrypt a h code pp n) + +-- | Opens data sealed with 'appEncrypt'. Needs a session. +appDecrypt :: Dongle -> ByteString -> IO ByteString +appDecrypt d@(Dongle h) packed = do + a <- api + useBytes packed $ \pp n -> readBytes (Just d) "licdf_app_decrypt" (fAppDecrypt a h pp n) diff --git a/src/KeyNub/LicDongle/Library.hs b/src/KeyNub/LicDongle/Library.hs new file mode 100644 --- /dev/null +++ b/src/KeyNub/LicDongle/Library.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | The native library: found, loaded once per process, and its functions +-- resolved by name into an 'Api' table. Applications use "KeyNub.LicDongle"; +-- this module is exposed for the two path functions and the error type. +module KeyNub.LicDongle.Library + ( Api(..) + , api + , setLibraryPath + , libraryPath + , loadedLibraryPath + , LibraryError(..) + ) where + +import Control.Concurrent.MVar +import Control.Exception (Exception, SomeException, throwIO, try) +import Data.Word (Word8) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (FunPtr, Ptr, castFunPtr) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (lookupEnv) +import System.FilePath ((), takeDirectory) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Info + +#if defined(mingw32_HOST_OS) +import Foreign.Ptr (castPtrToFunPtr) +import System.Win32.DLL (getProcAddress, loadLibrary) +import System.Win32.Types (HMODULE) +#else +import System.Posix.DynamicLinker (DL, RTLDFlags(..), dlopen, dlsym) +#endif + +-- | Loading problems: no library found, or a library without the expected +-- functions. +newtype LibraryError = LibraryError String + deriving (Eq, Show) + +instance Exception LibraryError + +-- Every shape of function the flat API has. +type F_ppp = Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CInt +type F_p = Ptr CInt -> IO CInt +type F_isi = CInt -> CString -> CInt -> IO CInt +type F_s = CString -> IO CInt +type F_i = CInt -> IO CInt +type F_ibi = CInt -> Ptr Word8 -> CInt -> IO CInt +type F_info = CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt + -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CInt +type F_genuine = CInt -> Ptr CInt -> CString -> CInt -> CString -> CInt -> IO CInt +type F_ip = CInt -> Ptr CInt -> IO CInt +type F_iip = CInt -> CInt -> Ptr CInt -> IO CInt +type F_name = CInt -> CInt -> CString -> CInt -> Ptr CInt -> IO CInt +type F_isp = CInt -> CString -> Ptr CInt -> IO CInt +type F_read = CInt -> CString -> Ptr Word8 -> CInt -> Ptr CInt -> IO CInt +type F_write = CInt -> CString -> Ptr Word8 -> CInt -> IO CInt +type F_is = CInt -> CString -> IO CInt +type F_enc = CInt -> CInt -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> Ptr CInt -> IO CInt +type F_dec = CInt -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> Ptr CInt -> IO CInt + +foreign import ccall "dynamic" mk_ppp :: FunPtr F_ppp -> F_ppp +foreign import ccall "dynamic" mk_p :: FunPtr F_p -> F_p +foreign import ccall "dynamic" mk_isi :: FunPtr F_isi -> F_isi +foreign import ccall "dynamic" mk_s :: FunPtr F_s -> F_s +foreign import ccall "dynamic" mk_i :: FunPtr F_i -> F_i +foreign import ccall "dynamic" mk_ibi :: FunPtr F_ibi -> F_ibi +foreign import ccall "dynamic" mk_info :: FunPtr F_info -> F_info +foreign import ccall "dynamic" mk_genuine :: FunPtr F_genuine -> F_genuine +foreign import ccall "dynamic" mk_ip :: FunPtr F_ip -> F_ip +foreign import ccall "dynamic" mk_iip :: FunPtr F_iip -> F_iip +foreign import ccall "dynamic" mk_name :: FunPtr F_name -> F_name +foreign import ccall "dynamic" mk_isp :: FunPtr F_isp -> F_isp +foreign import ccall "dynamic" mk_read :: FunPtr F_read -> F_read +foreign import ccall "dynamic" mk_write :: FunPtr F_write -> F_write +foreign import ccall "dynamic" mk_is :: FunPtr F_is -> F_is +foreign import ccall "dynamic" mk_enc :: FunPtr F_enc -> F_enc +foreign import ccall "dynamic" mk_dec :: FunPtr F_dec -> F_dec + +-- | The flat API's functions, resolved from the loaded library. +data Api = Api + { fVersion :: F_ppp + , fDeviceCount :: F_p + , fDeviceSerial :: F_isi + , fDevicePath :: F_isi + , fOpen :: F_s + , fOpenPath :: F_s + , fClose :: F_i + , fSetTrustRoot :: F_ibi + , fGetSerial :: F_isi + , fGetInfo :: F_info + , fVerifyGenuine :: F_genuine + , fSessionOpen :: F_i + , fSessionClose :: F_i + , fWriteAuth :: F_ibi + , fWriteAuthRotate :: F_ibi + , fRecordCount :: F_ip + , fRecordName :: F_name + , fRecordSize :: F_isp + , fRecordRead :: F_read + , fRecordWrite :: F_write + , fRecordErase :: F_is + , fRecordEraseAll :: F_i + , fCounterRead :: F_iip + , fCounterIncrement :: F_iip + , fAppEncrypt :: F_enc + , fAppDecrypt :: F_dec + , fStrerror :: F_isi + , fLastError :: F_isi + } + +data State = State + { chosen :: Maybe FilePath -- named with setLibraryPath, not yet loaded + , loaded :: Maybe (FilePath, Api) + } + +{-# NOINLINE stateVar #-} +stateVar :: MVar State +stateVar = unsafePerformIO (newMVar (State Nothing Nothing)) + +-- | Names the native library to load. Call it before the first call; once a +-- library is loaded, naming a different one throws 'LibraryError'. +setLibraryPath :: FilePath -> IO () +setLibraryPath p = modifyMVar_ stateVar $ \st -> case loaded st of + Just (lp, _) | lp /= p -> + throwIO (LibraryError ("the KeyNub library is already loaded from " ++ lp + ++ "; a process loads it once")) + _ -> pure st { chosen = Just p } + +-- | The library in use, or the one the next call would load. +libraryPath :: IO FilePath +libraryPath = do + st <- readMVar stateVar + case loaded st of + Just (lp, _) -> pure lp + Nothing -> resolve (chosen st) + +-- | The library in use, once one is loaded. +loadedLibraryPath :: IO (Maybe FilePath) +loadedLibraryPath = fmap fst . loaded <$> readMVar stateVar + +-- | The function table, loading the library on the first call. +api :: IO Api +api = modifyMVar stateVar $ \st -> case loaded st of + Just (_, a) -> pure (st, a) + Nothing -> do + p <- resolve (chosen st) + a <- load p + pure (st { loaded = Just (p, a) }, a) + +-- The path given to setLibraryPath, then KEYNUB_LICDONGLE_FLAT_LIBRARY, then +-- natives// from the working directory upwards (a clone of the SDK +-- repository), then the bare name for the system loader to find. +resolve :: Maybe FilePath -> IO FilePath +resolve (Just p) = pure p +resolve Nothing = do + env <- lookupEnv "KEYNUB_LICDONGLE_FLAT_LIBRARY" + case env of + Just p | not (null p) -> pure p + _ -> do + found <- searchNatives + pure (maybe basename id found) + +basename :: FilePath +basename = case System.Info.os of + "mingw32" -> "keynub_licdongle_flat.dll" + "darwin" -> "libkeynub_licdongle_flat.dylib" + _ -> "libkeynub_licdongle_flat.so" + +-- The natives/ folder name of the SDK repository for this process. +platformFolder :: Maybe String +platformFolder = case (System.Info.os, System.Info.arch) of + ("mingw32", "x86_64") -> Just "win-x64" + ("mingw32", "i386") -> Just "win-x86" + ("mingw32", "aarch64") -> Just "win-arm64" + ("linux", "x86_64") -> Just "linux-x64" + ("linux", "aarch64") -> Just "linux-arm64" + ("darwin", "x86_64") -> Just "osx-x64" + ("darwin", "aarch64") -> Just "osx-arm64" + _ -> Nothing + +searchNatives :: IO (Maybe FilePath) +searchNatives = case platformFolder of + Nothing -> pure Nothing + Just rid -> getCurrentDirectory >>= go rid + where + go rid dir = do + let candidate = dir "natives" rid basename + present <- doesFileExist candidate + if present + then pure (Just candidate) + else let parent = takeDirectory dir + in if parent == dir then pure Nothing else go rid parent + +load :: FilePath -> IO Api +load path = do + sym <- opener path + let get :: String -> IO (FunPtr a) + get name = castFunPtr <$> sym name + Api <$> (mk_ppp <$> get "licdf_version") + <*> (mk_p <$> get "licdf_device_count") + <*> (mk_isi <$> get "licdf_device_serial") + <*> (mk_isi <$> get "licdf_device_path") + <*> (mk_s <$> get "licdf_open") + <*> (mk_s <$> get "licdf_open_path") + <*> (mk_i <$> get "licdf_close") + <*> (mk_ibi <$> get "licdf_set_trust_root") + <*> (mk_isi <$> get "licdf_get_serial") + <*> (mk_info <$> get "licdf_get_info") + <*> (mk_genuine <$> get "licdf_verify_genuine") + <*> (mk_i <$> get "licdf_session_open") + <*> (mk_i <$> get "licdf_session_close") + <*> (mk_ibi <$> get "licdf_write_auth") + <*> (mk_ibi <$> get "licdf_write_auth_rotate") + <*> (mk_ip <$> get "licdf_record_count") + <*> (mk_name <$> get "licdf_record_name") + <*> (mk_isp <$> get "licdf_record_size") + <*> (mk_read <$> get "licdf_record_read") + <*> (mk_write <$> get "licdf_record_write") + <*> (mk_is <$> get "licdf_record_erase") + <*> (mk_i <$> get "licdf_record_erase_all") + <*> (mk_iip <$> get "licdf_counter_read") + <*> (mk_iip <$> get "licdf_counter_increment") + <*> (mk_enc <$> get "licdf_app_encrypt") + <*> (mk_dec <$> get "licdf_app_decrypt") + <*> (mk_isi <$> get "licdf_strerror") + <*> (mk_isi <$> get "licdf_last_error") + +-- Opens the library and gives a symbol lookup over it. +opener :: FilePath -> IO (String -> IO (FunPtr ())) +#if defined(mingw32_HOST_OS) +opener path = do + r <- try (loadLibrary path) :: IO (Either SomeException HMODULE) + handle <- either (cannotLoad path) pure r + pure $ \name -> do + r2 <- try (getProcAddress handle name) :: IO (Either SomeException (Ptr ())) + either (missing path name) (pure . castPtrToFunPtr) r2 +#else +opener path = do + r <- try (dlopen path [RTLD_NOW]) :: IO (Either SomeException DL) + dl <- either (cannotLoad path) pure r + pure $ \name -> do + r2 <- try (dlsym dl name) :: IO (Either SomeException (FunPtr ())) + either (missing path name) pure r2 +#endif + +cannotLoad :: FilePath -> SomeException -> IO a +cannotLoad path e = throwIO (LibraryError ("cannot load the KeyNub library " ++ path ++ ": " ++ show e)) + +missing :: FilePath -> String -> SomeException -> IO a +missing path name _ = throwIO (LibraryError (path ++ " does not export " ++ name)) diff --git a/test/StubTest.hs b/test/StubTest.hs new file mode 100644 --- /dev/null +++ b/test/StubTest.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- Every call of the binding against a stand-in for the flat C API: the SDK's +-- flat layer compiled together with the C ABI stand-in +-- (bindings/julia/test/stub/licd_stub.c, one imaginary dongle held in memory) +-- into one shared library, with a C compiler from the path (cc, gcc, clang or +-- zig cc). KEYNUB_LICDONGLE_FLAT_LIBRARY naming an already compiled stand-in +-- skips the build. Exit code 0 when every check passed. +module Main (main) where + +import Control.Exception (SomeException, try) +import Control.Monad (forM_, unless) +import Data.Bits (xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import Data.IORef +import Data.List (sort) +import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, getTemporaryDirectory) +import System.Environment (lookupEnv) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath ((), takeDirectory) +import qualified System.Info +import System.Process (readProcessWithExitCode) +import System.Exit (ExitCode(..)) + +import KeyNub.LicDongle + +main :: IO () +main = do + lib <- standIn + setLibraryPath lib + failures <- newIORef (0 :: Int) + let check cond what = unless cond $ do + modifyIORef' failures (+ 1) + putStrLn (" FAIL " ++ what) + fails st what act = do + r <- try act + case r of + Left (e :: LicDongleError) -> check (errorStatus e == st) (what ++ ": " ++ show (errorStatus e)) + Right _ -> check False (what ++ ": no failure") + serialValue = "04A1B2C3D4E5F6" + factoryKey = BS.pack [0x30, 0x10, 0x01, 0x02, 0x03] + replacementKey = BS.pack [0x30, 0x11, 0x09, 0x08, 0x07, 0x06] + + v <- libraryVersion + check (v == (9, 8, 7)) "the stand-in reports 9.8.7" + t <- statusText (-2) + check (t == "no device") "strerror text" + + ds <- devices + check (ds == [Device serialValue "stub:0"]) "enumeration" + fails NoDevice "open with a wrong serial" (openSerial "nope") + fails NoDevice "open at a wrong path" (openPath "stub:9") + + d <- open + s <- serial d + check (s == serialValue) "serial" + i <- info d + check (protocolVersion i == (1, 0) && firmwareVersion i == (2, 3, 4)) "versions" + check (secureElementReady i && provisioned i && isolated i) "flags set" + check (not (watchdogReboot i) && not (writeAuthRotated i)) "flags clear" + check (dataCapacity i == 1024 * 1024 && dataFree i == 1000000) "storage" + g <- verifyGenuine d + check (genuineSerial g == serialValue && provisionedDate g == "2026-08-15") "genuine" + isGenuine d >>= \ok -> check ok "isGenuine" + + fails CertInvalid "a non-DER root is refused" (setTrustRoot d (BS.pack [0x02, 0x01, 0x00])) + setTrustRoot d (BS.pack ([0x30, 0x82, 0x01, 0x00] ++ replicate 128 0xAB)) + fails CertInvalid "verification under a foreign root" (verifyGenuine d) + isGenuine d >>= \ok -> check (not ok) "isGenuine fails closed" + setTrustRoot d (BS.pack ([0x30, 0x82, 0x01, 0x00] ++ replicate 128 0x01)) + isGenuine d >>= \ok -> check ok "genuine again under the issuing root" + + fails SessionExpired "records need a session" (records d) + sessionOpen d + let payload = BC.pack "license-blob-0123456789" + fails AuthRequired "writing needs the write role" (writeRecord d "lic" payload) + fails NotGenuine "a wrong key does not elevate" (authorizeWrite d (BS.pack [0x30, 0x00])) + authorizeWrite d factoryKey + writeRecord d "lic" payload + readRecord d "lic" >>= \r -> check (r == payload) "read back what was written" + writeRecord d "cfg" (BC.pack "cfgdata") + recs <- records d + check (sort (map recordName recs) == ["cfg", "lic"]) "record names" + check ([recordSize r | r <- recs, recordName r == "lic"] == [BS.length payload]) "record size" + readRecord d "cfg" >>= \r -> check (BC.unpack r == "cfgdata") "a string is stored as its bytes" + fails NotFound "reading a missing record" (readRecord d "nope") + fails InvalidArg "an empty name never erases" (eraseRecord d "") + records d >>= \rs -> check (length rs == 2) "nothing erased by mistake" + eraseRecord d "cfg" + records d >>= \rs -> check (map recordName rs == ["lic"]) "one record after the erase" + writeRecord d "empty" BS.empty + readRecord d "empty" >>= \r -> check (r == BS.empty) "an empty record reads back empty" + + before <- readCounter d 0 + incrementCounter d 0 >>= \n -> check (n == before + 1) "increment returns the new value" + c0 <- readCounter d 0 + c1 <- readCounter d 1 + check (c0 == before + 1 && c1 == 0) "counters" + fails Range "a counter the dongle lacks" (readCounter d 7) + + let secret = BS.pack [fromIntegral ((3 * k + 7) `mod` 256) | k <- [0 .. 99 :: Int]] + forM_ [(DeviceScope, 0), (DeveloperScope, 1)] $ \(scope, byte) -> do + blob <- appEncrypt d scope secret + check (BS.length blob > BS.length secret) ("sealed data is longer, " ++ show scope) + check (BS.head blob == byte) ("scope byte " ++ show scope) + appDecrypt d blob >>= \r -> check (r == secret) ("round trip " ++ show scope) + let tampered = BS.init blob `BS.snoc` (BS.last blob `xor` 1) + fails TagMismatch ("tampered data " ++ show scope) (appDecrypt d tampered) + eraseAllRecords d + records d >>= \rs -> check (null rs) "erase all leaves nothing" + + rotateWriteKey d replacementKey + writeRecord d "lic" (BC.pack "still-writable") + sessionClose d + info d >>= \i2 -> check (writeAuthRotated i2) "the rotation flag is set" + sessionOpen d + fails NotGenuine "the factory key no longer elevates" (authorizeWrite d factoryKey) + authorizeWrite d replacementKey + writeRecord d "lic" (BC.pack "new-key-writes") + readRecord d "lic" >>= \r -> check (BC.unpack r == "new-key-writes") "the new key writes" + sessionClose d + close d + r <- try (serial d) + check (either (\(_ :: LicDongleError) -> True) (const False) r) "a closed handle refuses calls" + + n <- readIORef failures + if n == 0 + then putStrLn "keynub-licdongle: every call passed against the ABI stand-in" >> exitSuccess + else putStrLn (show n ++ " check(s) failed") >> exitFailure + +-- The compiled stand-in: from the environment, or built from the SDK sources +-- found by walking up from the working directory. +standIn :: IO FilePath +standIn = do + env <- lookupEnv "KEYNUB_LICDONGLE_FLAT_LIBRARY" + case env of + Just p | not (null p) -> pure p + _ -> do + root <- sdkRoot + tmp <- getTemporaryDirectory + let dir = tmp "keynub-haskell-stub" + out = dir libName + createDirectoryIfMissing True dir + let args = ["-shared", "-O1", "-DLICD_BUILD_SHARED", "-DLICDF_BUILD_SHARED", + "-I" ++ (root "core" "include"), "-I" ++ (root "bindings" "flat"), + "-o", out, + root "bindings" "flat" "licd_flat.c", + root "bindings" "julia" "test" "stub" "licd_stub.c"] + ++ (if System.Info.os == "mingw32" then [] else ["-fPIC"]) + ok <- tryCompilers [("cc", []), ("gcc", []), ("clang", []), ("zig", ["cc"])] args + unless ok $ do + putStrLn "the C ABI stand-in could not be compiled: no C compiler (cc, gcc, clang, zig cc) on the path" + exitFailure + pure out + where + libName = case System.Info.os of + "mingw32" -> "keynub_licdongle_flat.dll" + "darwin" -> "libkeynub_licdongle_flat.dylib" + _ -> "libkeynub_licdongle_flat.so" + tryCompilers [] _ = pure False + tryCompilers ((exe, pre) : rest) args = do + r <- try (readProcessWithExitCode exe (pre ++ args) "") :: IO (Either SomeException (ExitCode, String, String)) + case r of + Right (ExitSuccess, _, _) -> pure True + Right (_, _, err) -> putStrLn (exe ++ ": " ++ err) >> tryCompilers rest args + Left _ -> tryCompilers rest args + +-- The SDK root: KEYNUB_SDK_ROOT, or the first directory upwards holding +-- bindings/flat/licd_flat.c. +sdkRoot :: IO FilePath +sdkRoot = do + env <- lookupEnv "KEYNUB_SDK_ROOT" + case env of + Just p | not (null p) -> pure p + _ -> getCurrentDirectory >>= go + where + go dir = do + present <- doesFileExist (dir "bindings" "flat" "licd_flat.c") + if present then pure dir else do + let parent = takeDirectory dir + if parent == dir + then putStrLn "the SDK sources were not found above the working directory; set KEYNUB_SDK_ROOT" >> exitFailure + else go parent