{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternSynonyms #-}

module Data.UCL
( UCL(..)
, parseString
, parseByteString
, parseFile
) where

import Foreign.C
  ( CUInt(..), CInt(..), CSize(..), CDouble(..), CString, CStringLen
  , newCString, peekCString )
import Foreign.Ptr (Ptr)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text.Foreign as TF
import Data.Text (Text)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Time.Clock (DiffTime)
import Data.ByteString (ByteString, useAsCStringLen)


newtype ParserHandle = ParserHandle (Ptr ())
newtype UCLObjectHandle = UCLObjectHandle (Ptr ())
newtype UCLIterHandle = UCLIterHandle (Ptr ())

type UCL_TYPE = CUInt
pattern UCL_OBJECT :: UCL_TYPE
pattern $bUCL_OBJECT :: UCL_TYPE
$mUCL_OBJECT :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_OBJECT = 0
pattern UCL_ARRAY :: UCL_TYPE
pattern $bUCL_ARRAY :: UCL_TYPE
$mUCL_ARRAY :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_ARRAY = 1
pattern UCL_INT :: UCL_TYPE
pattern $bUCL_INT :: UCL_TYPE
$mUCL_INT :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_INT = 2
pattern UCL_FLOAT :: UCL_TYPE
pattern $bUCL_FLOAT :: UCL_TYPE
$mUCL_FLOAT :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_FLOAT = 3
pattern UCL_STRING :: UCL_TYPE
pattern $bUCL_STRING :: UCL_TYPE
$mUCL_STRING :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_STRING = 4
pattern UCL_BOOLEAN :: UCL_TYPE
pattern $bUCL_BOOLEAN :: UCL_TYPE
$mUCL_BOOLEAN :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_BOOLEAN = 5
pattern UCL_TIME :: UCL_TYPE
pattern $bUCL_TIME :: UCL_TYPE
$mUCL_TIME :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_TIME = 6
pattern UCL_USERDATA :: UCL_TYPE
pattern $bUCL_USERDATA :: UCL_TYPE
$mUCL_USERDATA :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_USERDATA = 7
pattern UCL_NULL :: UCL_TYPE
pattern $bUCL_NULL :: UCL_TYPE
$mUCL_NULL :: forall r. UCL_TYPE -> (Void# -> r) -> (Void# -> r) -> r
UCL_NULL = 8


foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> IO ParserHandle
foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool
foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool
foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> IO UCLObjectHandle
foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> IO CString

foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> IO UCLIterHandle
foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> IO UCLObjectHandle
foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> UCL_TYPE
foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString
foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt
foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble
foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString
foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool

foreign import ccall "strlen" c_strlen :: CString -> IO CSize


peekCStringText :: CString -> IO Text
peekCStringText :: CString -> IO Text
peekCStringText cstr :: CString
cstr = do
  CSize
len <- CString -> IO CSize
c_strlen CString
cstr
  CStringLen -> IO Text
TF.peekCStringLen (CString
cstr, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len)

-- | Parse a 'ByteString' into a 'UCL', resolving includes, macros, variables...
-- Note that unicode does not get converted when using 'fromString'.
-- Prefer 'parseString' when working on 'String's or literals.
--
-- >>> parseByteString $ fromString "{a: [1,2], b: 3min, a: [4]}"
-- Right (UCLMap (fromList
--   [ ("a", UCLArray [UCLInt 1, UCLInt 2, UCLInt 4])
--   , ("b", UCLTime 180s                           )
--   ]))
--
-- This function is __not__ safe to call on untrusted input: configurations can
-- read files, make http requests, do "billion laughs" attacks, and possibly
-- crash the parser.
parseByteString :: ByteString -> IO (Either String UCL)
parseByteString :: ByteString -> IO (Either String UCL)
parseByteString bs :: ByteString
bs = ByteString
-> (CStringLen -> IO (Either String UCL)) -> IO (Either String UCL)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen ByteString
bs CStringLen -> IO (Either String UCL)
parseCStringLen

-- | Parse a 'String' into a 'UCL', resolving includes, macros, variables...
--
-- >>> parseString "{a: [1,2], 🌅: 3min, a: [4]}"
-- Right (UCLMap (fromList
--   [ ("a"      , UCLArray [UCLInt 1, UCLInt 2, UCLInt 4])
--   , ("\127749", UCLTime 180s                           )
--   ]))
--
-- This function is __not__ safe to call on untrusted input: configurations can
-- read files, make http requests, do "billion laughs" attacks, and possibly
-- crash the parser.
parseString :: String -> IO (Either String UCL)
parseString :: String -> IO (Either String UCL)
parseString s :: String
s = do
  CString
cs <- String -> IO CString
newCString String
s
  CStringLen -> IO (Either String UCL)
parseCStringLen (CString
cs, String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)

parseCStringLen :: CStringLen -> IO (Either String UCL)
parseCStringLen :: CStringLen -> IO (Either String UCL)
parseCStringLen (cs :: CString
cs, len :: Int
len) = do
  ParserHandle
p <- CInt -> IO ParserHandle
ucl_parser_new 0x0
  Bool
didParse <- ParserHandle -> CString -> UCL_TYPE -> IO Bool
ucl_parser_add_string ParserHandle
p CString
cs (UCL_TYPE -> IO Bool) -> UCL_TYPE -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> UCL_TYPE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
  if Bool
didParse
  then UCL -> Either String UCL
forall a b. b -> Either a b
Right (UCL -> Either String UCL)
-> (UCLObjectHandle -> UCL) -> UCLObjectHandle -> Either String UCL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UCLObjectHandle -> UCL
handleToUCL (UCLObjectHandle -> Either String UCL)
-> IO UCLObjectHandle -> IO (Either String UCL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserHandle -> IO UCLObjectHandle
ucl_parser_get_object ParserHandle
p
  else String -> Either String UCL
forall a b. a -> Either a b
Left (String -> Either String UCL)
-> IO String -> IO (Either String UCL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParserHandle -> IO CString
ucl_parser_get_error ParserHandle
p IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString)

-- | Parse the contents of a file into a 'UCL', resolving includes, macros,
-- variables...
--
-- This function is __not__ safe to call on untrusted input: configurations can
-- read files, make http requests, do "billion laughs" attacks, and possibly
-- crash the parser.
parseFile :: FilePath -> IO (Either String UCL)
parseFile :: String -> IO (Either String UCL)
parseFile s :: String
s = do
    CString
cs <- String -> IO CString
newCString String
s
    ParserHandle
p <- CInt -> IO ParserHandle
ucl_parser_new 0x0
    Bool
didParse <- ParserHandle -> CString -> IO Bool
ucl_parser_add_file ParserHandle
p CString
cs
    if Bool
didParse
    then UCL -> Either String UCL
forall a b. b -> Either a b
Right (UCL -> Either String UCL)
-> (UCLObjectHandle -> UCL) -> UCLObjectHandle -> Either String UCL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UCLObjectHandle -> UCL
handleToUCL (UCLObjectHandle -> Either String UCL)
-> IO UCLObjectHandle -> IO (Either String UCL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserHandle -> IO UCLObjectHandle
ucl_parser_get_object ParserHandle
p
    else String -> Either String UCL
forall a b. a -> Either a b
Left (String -> Either String UCL)
-> IO String -> IO (Either String UCL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParserHandle -> IO CString
ucl_parser_get_error ParserHandle
p IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString)

-- | An UCL object
data UCL = UCLMap (Map Text UCL)
         | UCLArray [UCL]
         | UCLInt Int
         | UCLDouble Double
         | UCLText Text
         | UCLBool Bool
         | UCLTime DiffTime
  deriving (Int -> UCL -> ShowS
[UCL] -> ShowS
UCL -> String
(Int -> UCL -> ShowS)
-> (UCL -> String) -> ([UCL] -> ShowS) -> Show UCL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UCL] -> ShowS
$cshowList :: [UCL] -> ShowS
show :: UCL -> String
$cshow :: UCL -> String
showsPrec :: Int -> UCL -> ShowS
$cshowsPrec :: Int -> UCL -> ShowS
Show, UCL -> UCL -> Bool
(UCL -> UCL -> Bool) -> (UCL -> UCL -> Bool) -> Eq UCL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UCL -> UCL -> Bool
$c/= :: UCL -> UCL -> Bool
== :: UCL -> UCL -> Bool
$c== :: UCL -> UCL -> Bool
Eq, Eq UCL
Eq UCL =>
(UCL -> UCL -> Ordering)
-> (UCL -> UCL -> Bool)
-> (UCL -> UCL -> Bool)
-> (UCL -> UCL -> Bool)
-> (UCL -> UCL -> Bool)
-> (UCL -> UCL -> UCL)
-> (UCL -> UCL -> UCL)
-> Ord UCL
UCL -> UCL -> Bool
UCL -> UCL -> Ordering
UCL -> UCL -> UCL
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UCL -> UCL -> UCL
$cmin :: UCL -> UCL -> UCL
max :: UCL -> UCL -> UCL
$cmax :: UCL -> UCL -> UCL
>= :: UCL -> UCL -> Bool
$c>= :: UCL -> UCL -> Bool
> :: UCL -> UCL -> Bool
$c> :: UCL -> UCL -> Bool
<= :: UCL -> UCL -> Bool
$c<= :: UCL -> UCL -> Bool
< :: UCL -> UCL -> Bool
$c< :: UCL -> UCL -> Bool
compare :: UCL -> UCL -> Ordering
$ccompare :: UCL -> UCL -> Ordering
$cp1Ord :: Eq UCL
Ord)

handleToUCL :: UCLObjectHandle -> UCL
handleToUCL :: UCLObjectHandle -> UCL
handleToUCL o :: UCLObjectHandle
o = UCL_TYPE -> UCLObjectHandle -> UCL
typedHandleToUCL (UCLObjectHandle -> UCL_TYPE
ucl_object_type UCLObjectHandle
o) UCLObjectHandle
o

typedHandleToUCL :: UCL_TYPE -> UCLObjectHandle -> UCL
typedHandleToUCL :: UCL_TYPE -> UCLObjectHandle -> UCL
typedHandleToUCL UCL_OBJECT   obj :: UCLObjectHandle
obj = Map Text UCL -> UCL
UCLMap (Map Text UCL -> UCL) -> Map Text UCL -> UCL
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> Map Text UCL
uclObjectToMap UCLObjectHandle
obj
typedHandleToUCL UCL_ARRAY    obj :: UCLObjectHandle
obj = [UCL] -> UCL
UCLArray ([UCL] -> UCL) -> [UCL] -> UCL
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> [UCL]
uclArrayToList UCLObjectHandle
obj
typedHandleToUCL UCL_INT      obj :: UCLObjectHandle
obj = Int -> UCL
UCLInt (Int -> UCL) -> Int -> UCL
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> CInt
ucl_object_toint UCLObjectHandle
obj
typedHandleToUCL UCL_FLOAT    obj :: UCLObjectHandle
obj = Double -> UCL
UCLDouble (Double -> UCL) -> Double -> UCL
forall a b. (a -> b) -> a -> b
$ CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> Double) -> CDouble -> Double
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> CDouble
ucl_object_todouble UCLObjectHandle
obj
typedHandleToUCL UCL_STRING   obj :: UCLObjectHandle
obj = Text -> UCL
UCLText (Text -> UCL) -> Text -> UCL
forall a b. (a -> b) -> a -> b
$ IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ CString -> IO Text
peekCStringText (CString -> IO Text) -> CString -> IO Text
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> CString
ucl_object_tostring UCLObjectHandle
obj
typedHandleToUCL UCL_BOOLEAN  obj :: UCLObjectHandle
obj = Bool -> UCL
UCLBool (Bool -> UCL) -> Bool -> UCL
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> Bool
ucl_object_toboolean UCLObjectHandle
obj
typedHandleToUCL UCL_TIME     obj :: UCLObjectHandle
obj = DiffTime -> UCL
UCLTime (DiffTime -> UCL) -> DiffTime -> UCL
forall a b. (a -> b) -> a -> b
$ CDouble -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> DiffTime) -> CDouble -> DiffTime
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> CDouble
ucl_object_todouble UCLObjectHandle
obj
typedHandleToUCL UCL_USERDATA _   = String -> UCL
forall a. HasCallStack => String -> a
error "Userdata object"
typedHandleToUCL UCL_NULL     _   = String -> UCL
forall a. HasCallStack => String -> a
error "Null object"
typedHandleToUCL _            _   = String -> UCL
forall a. HasCallStack => String -> a
error "Unknown Type"

uclObjectToMap :: UCLObjectHandle -> Map Text UCL
uclObjectToMap :: UCLObjectHandle -> Map Text UCL
uclObjectToMap o :: UCLObjectHandle
o = IO (Map Text UCL) -> Map Text UCL
forall a. IO a -> a
unsafePerformIO (IO (Map Text UCL) -> Map Text UCL)
-> IO (Map Text UCL) -> Map Text UCL
forall a b. (a -> b) -> a -> b
$ do
  UCLIterHandle
iter <- UCLObjectHandle -> IO UCLIterHandle
ucl_object_iterate_new UCLObjectHandle
o
  UCLIterHandle -> Map Text UCL -> IO (Map Text UCL)
go UCLIterHandle
iter Map Text UCL
forall k a. Map k a
Map.empty
  where 
    go :: UCLIterHandle -> Map Text UCL -> IO (Map Text UCL)
go it :: UCLIterHandle
it m :: Map Text UCL
m = do
      UCLObjectHandle
obj <- UCLIterHandle -> Bool -> IO UCLObjectHandle
ucl_object_iterate_safe UCLIterHandle
it Bool
True
      case UCLObjectHandle -> UCL_TYPE
ucl_object_type UCLObjectHandle
obj of
        UCL_NULL -> Map Text UCL -> IO (Map Text UCL)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text UCL
m
        _        -> UCLIterHandle -> Map Text UCL -> IO (Map Text UCL)
go UCLIterHandle
it (Map Text UCL -> IO (Map Text UCL))
-> Map Text UCL -> IO (Map Text UCL)
forall a b. (a -> b) -> a -> b
$ Text -> UCL -> Map Text UCL -> Map Text UCL
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UCLObjectHandle -> Text
getUclKey UCLObjectHandle
obj) (UCLObjectHandle -> UCL
handleToUCL UCLObjectHandle
obj) Map Text UCL
m
    getUclKey :: UCLObjectHandle -> Text
getUclKey obj :: UCLObjectHandle
obj = IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ CString -> IO Text
peekCStringText (CString -> IO Text) -> CString -> IO Text
forall a b. (a -> b) -> a -> b
$ UCLObjectHandle -> CString
ucl_object_key UCLObjectHandle
obj

uclArrayToList :: UCLObjectHandle -> [UCL]
uclArrayToList :: UCLObjectHandle -> [UCL]
uclArrayToList o :: UCLObjectHandle
o = IO [UCL] -> [UCL]
forall a. IO a -> a
unsafePerformIO (IO [UCL] -> [UCL]) -> IO [UCL] -> [UCL]
forall a b. (a -> b) -> a -> b
$ do
  UCLIterHandle
iter <- UCLObjectHandle -> IO UCLIterHandle
ucl_object_iterate_new UCLObjectHandle
o
  UCLIterHandle -> IO [UCL]
go UCLIterHandle
iter
  where 
    go :: UCLIterHandle -> IO [UCL]
go it :: UCLIterHandle
it = do
      UCLObjectHandle
obj <- UCLIterHandle -> Bool -> IO UCLObjectHandle
ucl_object_iterate_safe UCLIterHandle
it Bool
True
      case UCLObjectHandle -> UCL_TYPE
ucl_object_type UCLObjectHandle
obj of
        UCL_NULL -> [UCL] -> IO [UCL]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        _        -> (UCLObjectHandle -> UCL
handleToUCL UCLObjectHandle
obj UCL -> [UCL] -> [UCL]
forall a. a -> [a] -> [a]
:) ([UCL] -> [UCL]) -> IO [UCL] -> IO [UCL]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UCLIterHandle -> IO [UCL]
go UCLIterHandle
it