Added resolveDNS

demo/echo-server/echo-server.cabal

@@ -59,6 +59,7 @@ library
     , transformers
     , validation
     , warp
+    , dns
   default-language: Haskell2010
 
 executable echo-server
@@ -98,4 +99,5 @@ executable echo-server
     , transformers
     , validation
     , warp
+    , dns
   default-language: Haskell2010

euler-hs.cabal

@@ -148,6 +148,7 @@ library
     , uuid
     , validation
     , vector
+    , dns
 
   hs-source-dirs:  src
 
@@ -275,6 +276,7 @@ test-suite language
     , uuid
     , vector
     , warp
+    , dns 
 
   hs-source-dirs: test src
 
@@ -309,5 +311,6 @@ test-suite db
     , servant
     , servant-mock
     , time
+    , dns
 
   hs-source-dirs: testDB

src/EulerHS/Framework/Flow/Interpreter.hs

@@ -39,6 +39,10 @@ import qualified Network.TLS.Extra.Cipher as TLS
 import qualified Servant.Client as S
 import           System.Process (readCreateProcess, shell)
 import           Unsafe.Coerce (unsafeCoerce)
+import qualified Network.DNS.Resolver as DNS
+import qualified Network.DNS.Lookup as DNSLookup
+import qualified Data.ByteString.Char8 as BS
+
 
 connect :: T.DBConfig be -> IO (T.DBResult (T.SqlConn be))
 connect cfg = do
@@ -282,6 +286,32 @@ interpretFlowMethod _ _ (L.GenerateGUID next) = do
 interpretFlowMethod _ _ (L.RunSysCmd cmd next) =
   next <$> readCreateProcess (shell cmd) ""
 
+-- interpretFlowMethod _ _ (L.ResolveDNS host next) = do
+--   pure $ next (Map.lookup host dnsDatabase)
+--   where
+--     dnsDatabase :: Map.Map Text Text
+--     dnsDatabase = Map.fromList
+--         [ ("example.com", "93.184.216.34")
+--         , ("google.com", "8.8.8.8")
+--         , ("openai.com", "104.18.25.24")
+--         ]
+
+interpretFlowMethod _ _ (L.ResolveDNS host next) = do
+    resolvSeed <- DNS.makeResolvSeed DNS.defaultResolvConf
+    result <- DNS.withResolver resolvSeed $ \resolver ->
+        DNSLookup.lookupA resolver (BS.pack $ Text.unpack host)
+    let ipAddresses = case result of
+            Right ips -> Just (Text.pack $ show (head ips))
+            Left _    -> Map.lookup host dnsDatabase -- Fallback to hardcoded
+    pure $ next ipAddresses
+  where
+    dnsDatabase :: Map.Map Text Text
+    dnsDatabase = Map.fromList
+        [ ("example.com", "93.184.216.34")
+        , ("google.com", "8.8.8.8")
+        , ("openai.com", "104.18.25.24")
+        ]
+
 ----------------------------------------------------------------------
 interpretFlowMethod mbFlowGuid rt (L.Fork _desc _newFlowGUID flow next) = do
   awaitableMVar <- newEmptyMVar

src/EulerHS/Framework/Flow/Language.hs

@@ -105,6 +105,12 @@ data FlowMethod (next :: Type) where
     -> (String -> next)
     -> FlowMethod next
 
+  ResolveDNS
+    :: HasCallStack
+    => Text
+    -> (Maybe Text -> next)
+    -> FlowMethod next
+
   Fork
     :: HasCallStack
     => T.Description
@@ -246,6 +252,7 @@ instance Functor FlowMethod where
     DelOption k cont -> DelOption k (f . cont)
     GenerateGUID cont -> GenerateGUID (f . cont)
     RunSysCmd cmd cont -> RunSysCmd cmd (f . cont)
+    ResolveDNS cmd cont -> ResolveDNS cmd (f . cont)
     Fork desc guid flow cont -> Fork desc guid flow (f . cont)
     Await time awaitable cont -> Await time awaitable (f . cont)
     ThrowException e cont -> ThrowException e (f . cont)
@@ -568,6 +575,8 @@ class (MonadMask m) => MonadFlow m where
   -- >   ...
   runSysCmd :: HasCallStack => String -> m String
 
+  resolveDNS :: HasCallStack => Text -> m (Maybe Text)
+
   -- | Inits an SQL connection using a config.
   --
   -- Returns an error (Left $ T.DBError T.ConnectionAlreadyExists msg)
@@ -813,6 +822,8 @@ instance MonadFlow Flow where
   generateGUID = liftFC $ GenerateGUID id
   {-# INLINEABLE runSysCmd #-}
   runSysCmd cmd = liftFC $ RunSysCmd cmd id
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS cmd = liftFC $ ResolveDNS cmd id
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection cfg = liftFC $ InitSqlDBConnection cfg id
   {-# INLINEABLE deinitSqlDBConnection #-}
@@ -869,6 +880,8 @@ instance MonadFlow m => MonadFlow (ReaderT r m) where
   generateGUID = lift generateGUID
   {-# INLINEABLE runSysCmd #-}
   runSysCmd = lift . runSysCmd
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS = lift . resolveDNS
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection = lift . initSqlDBConnection
   {-# INLINEABLE deinitSqlDBConnection #-}
@@ -921,6 +934,8 @@ instance MonadFlow m => MonadFlow (StateT s m) where
   generateGUID = lift generateGUID
   {-# INLINEABLE runSysCmd #-}
   runSysCmd = lift . runSysCmd
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS = lift . resolveDNS
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection = lift . initSqlDBConnection
   {-# INLINEABLE deinitSqlDBConnection #-}
@@ -973,6 +988,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (WriterT w m) where
   generateGUID = lift generateGUID
   {-# INLINEABLE runSysCmd #-}
   runSysCmd = lift . runSysCmd
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS = lift . resolveDNS
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection = lift . initSqlDBConnection
   {-# INLINEABLE deinitSqlDBConnection #-}
@@ -1025,6 +1042,8 @@ instance MonadFlow m => MonadFlow (ExceptT e m) where
   generateGUID = lift generateGUID
   {-# INLINEABLE runSysCmd #-}
   runSysCmd = lift . runSysCmd
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS = lift . resolveDNS
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection = lift . initSqlDBConnection
   {-# INLINEABLE deinitSqlDBConnection #-}
@@ -1077,6 +1096,8 @@ instance (MonadFlow m, Monoid w) => MonadFlow (RWST r w s m) where
   generateGUID = lift generateGUID
   {-# INLINEABLE runSysCmd #-}
   runSysCmd = lift . runSysCmd
+  {-# INLINEABLE resolveDNS #-}
+  resolveDNS = lift . resolveDNS
   {-# INLINEABLE initSqlDBConnection #-}
   initSqlDBConnection = lift . initSqlDBConnection
   {-# INLINEABLE deinitSqlDBConnection #-}

test/EulerHS/Testing/Flow/Interpreter.hs

@@ -13,6 +13,7 @@ import           EulerHS.Testing.Types (FlowMockedValues)
 import           GHC.TypeLits (KnownSymbol, Symbol)
 import           Type.Reflection (typeRep)
 import           Unsafe.Coerce (unsafeCoerce)
+import qualified Data.Map as Map
 
 runFlowWithTestInterpreter :: FlowMockedValues -> FlowRuntime -> Flow a -> IO a
 runFlowWithTestInterpreter mv flowRt = foldFlow (interpretFlowMethod mv flowRt)
@@ -26,6 +27,13 @@ interpretFlowMethod mmv _ = \case
   L.SetOption _ _ next -> pure . next $ ()
   L.GenerateGUID next -> next <$> takeMockedVal @"mockedGenerateGUID" mmv
   L.RunSysCmd _ next -> next <$> takeMockedVal @"mockedRunSysCmd" mmv
+  L.ResolveDNS host next -> do
+    let dnsDatabase = Map.fromList
+            [ ("example.com", "93.184.216.34")
+            , ("google.com", "8.8.8.8")
+            , ("openai.com", "104.18.25.24")
+            ]
+    pure $ next (Map.lookup host dnsDatabase)
   _ -> error "not yet supported."
 
 takeMockedVal :: forall (f :: Symbol) (a :: Type) (r :: Type)

test/EulerHS/Testing/Types.hs

@@ -10,6 +10,7 @@ data FlowMockedValues' = FlowMockedValues'
   , mockedGetOption      :: [ByteString]
   , mockedGenerateGUID   :: [Text]
   , mockedRunSysCmd      :: [String]
+  , mockedDNS            :: [Maybe Text]
   } deriving (Generic, Typeable)
 
 

test/EulerHS/Tests/Framework/FlowSpec.hs

@@ -364,13 +364,17 @@ localGUID = unsafeCoerce ("FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF" :: String)
 lhost :: ByteString
 lhost = "localhost"
 
+domainName :: Maybe Text
+domainName = Just "93.184.216.34"
+
 scenario1MockedValues :: FlowMockedValues'
 scenario1MockedValues = FlowMockedValues'
   { mockedCallServantAPI = [user]
   , mockedRunIO = [localGUID]
   , mockedGetOption = [lhost]
   , mockedGenerateGUID = ["00000000-0000-0000-0000-000000000000"]
   , mockedRunSysCmd = ["Neo"]
+  , mockedDNS = [domainName]
   }
 
 ioActWithException :: IO Text