diff --git a/Guide/config.markdown b/Guide/config.markdown index 0b01ff8d7..a097bbcf6 100644 --- a/Guide/config.markdown +++ b/Guide/config.markdown @@ -16,6 +16,8 @@ The recommended way is to declare a custom `newtype` in `Config/Config.hs` like ```haskell -- Config.hs +import IHP.EnvVar + newtype StripePublicKey = StripePublicKey Text ``` @@ -24,6 +26,8 @@ We want our new config parameter to be filled from a `STRIPE_PUBLIC_KEY` env var ```haskell module Config where +import IHP.EnvVar + newtype StripePublicKey = StripePublicKey Text config :: ConfigBuilder diff --git a/Guide/database.markdown b/Guide/database.markdown index e9cf1fcc3..ad11bdf02 100644 --- a/Guide/database.markdown +++ b/Guide/database.markdown @@ -826,8 +826,6 @@ incomplete data is left in the database when there's an error. The [`withTransaction`](https://ihp.digitallyinduced.com/api-docs/IHP-ModelSupport.html#v:withTransaction) function will automatically commit after it succesfully executed the passed do-block. When any exception is thrown, it will automatically rollback. -### Common Pitfalls - Keep in mind that some IHP functions like [`redirectTo`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Redirect.html#v:redirectTo) or [`render`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Render.html#v:render) throw a [`ResponseException`](https://ihp.digitallyinduced.com/api-docs/IHP-ControllerSupport.html#t:ResponseException). So code like below will not work as expected: ```haskell diff --git a/IHP/HaskellSupport.hs b/IHP/HaskellSupport.hs index 92f18cdfc..0bf56b06b 100644 --- a/IHP/HaskellSupport.hs +++ b/IHP/HaskellSupport.hs @@ -50,6 +50,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec import Data.String.Conversions (cs, ConvertibleStrings (..)) import qualified Debug.Trace import qualified Data.Text as Text +import qualified Data.Map as Map import qualified Data.ByteString.Char8 as ByteString import qualified Data.Aeson.Key as Aeson @@ -86,6 +87,10 @@ instance IsEmpty UUID.UUID where isEmpty uuid = UUID.nil == uuid {-# INLINE isEmpty #-} +instance IsEmpty (Map a b) where + isEmpty = Map.null + {-# INLINE isEmpty #-} + ifOrEmpty :: (Monoid a) => Bool -> a -> a ifOrEmpty bool a = if bool then a else mempty {-# INLINE ifOrEmpty #-} @@ -445,4 +450,4 @@ allEnumValues = enumFrom (toEnum 0) instance ConvertibleStrings ByteString Aeson.Key where convertString byteString = Aeson.fromText (cs byteString) instance ConvertibleStrings Text Aeson.Key where - convertString text = Aeson.fromText text \ No newline at end of file + convertString text = Aeson.fromText text diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 8bcff36fd..dfd521681 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -450,7 +450,7 @@ findForeignKeyConstraint CreateTable { name } column = compileEnumDataDefinitions :: (?schema :: Schema) => Statement -> Text compileEnumDataDefinitions CreateEnumType { values = [] } = "" -- Ignore enums without any values compileEnumDataDefinitions enum@(CreateEnumType { name, values }) = - "data " <> modelName <> " = " <> (intercalate " | " valueConstructors) <> " deriving (Eq, Show, Read, Enum, Bounded)\n" + "data " <> modelName <> " = " <> (intercalate " | " valueConstructors) <> " deriving (Eq, Show, Read, Enum, Bounded, Ord)\n" <> "instance FromField " <> modelName <> " where\n" <> indent (unlines (map compileFromFieldInstanceForValue values)) <> " fromField field (Just value) = returnError ConversionFailed field (\"Unexpected value for enum value. Got: \" <> Data.String.Conversions.cs value)\n" diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 03d6dbc94..704eff7bd 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -19,7 +19,7 @@ tests = do let output = compileStatementPreview [statement] statement |> Text.strip output `shouldBe` [trimming| - data Mood = Happy | VeryHappy | Sad | VerySad deriving (Eq, Show, Read, Enum, Bounded) + data Mood = Happy | VeryHappy | Sad | VerySad deriving (Eq, Show, Read, Enum, Bounded, Ord) instance FromField Mood where fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "happy") = pure Happy fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "very happy") = pure VeryHappy @@ -56,7 +56,7 @@ tests = do let output = compileStatementPreview [statement] statement |> Text.strip output `shouldBe` [trimming| - data Province = Alberta | Britishcolumbia | Saskatchewan | Manitoba | Ontario | Quebec | Novascotia | Newbrunswick | Princeedwardisland | Newfoundlandandlabrador deriving (Eq, Show, Read, Enum, Bounded) + data Province = Alberta | Britishcolumbia | Saskatchewan | Manitoba | Ontario | Quebec | Novascotia | Newbrunswick | Princeedwardisland | Newfoundlandandlabrador deriving (Eq, Show, Read, Enum, Bounded, Ord) instance FromField Province where fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Alberta") = pure Alberta fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "BritishColumbia") = pure Britishcolumbia @@ -102,7 +102,7 @@ tests = do let output = compileStatementPreview [enum1, enum2] enum1 |> Text.strip output `shouldBe` [trimming| - data PropertyType = PropertyTypeApartment | House deriving (Eq, Show, Read, Enum, Bounded) + data PropertyType = PropertyTypeApartment | House deriving (Eq, Show, Read, Enum, Bounded, Ord) instance FromField PropertyType where fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "APARTMENT") = pure PropertyTypeApartment fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "HOUSE") = pure House diff --git a/ihp-openai/IHP/OpenAI.hs b/ihp-openai/IHP/OpenAI.hs index 3991d43e5..f5ba2daf1 100644 --- a/ihp-openai/IHP/OpenAI.hs +++ b/ihp-openai/IHP/OpenAI.hs @@ -120,45 +120,56 @@ streamCompletion secretKey completionRequest' onStart callback = do streamCompletionWithoutRetry :: ByteString -> CompletionRequest -> IO () -> (Text -> IO ()) -> IO (Either Text Text) streamCompletionWithoutRetry secretKey completionRequest' onStart callback = do - let completionRequest = enableStream completionRequest' - modifyContextSSL (\context -> do - SSL.contextSetVerificationMode context SSL.VerifyNone - pure context - ) - withOpenSSL do - withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do - let q = buildRequest1 do - http POST "/v1/chat/completions" - setContentType "application/json" - Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) - - sendRequest connection q (jsonBody completionRequest) + let completionRequest = enableStream completionRequest' + modifyContextSSL (\context -> do + SSL.contextSetVerificationMode context SSL.VerifyNone + pure context + ) + withOpenSSL do + withConnection (establishConnection "https://api.openai.com/v1/chat/completions") \connection -> do + let q = buildRequest1 do + http POST "/v1/chat/completions" + setContentType "application/json" + Network.Http.Client.setHeader "Authorization" ("Bearer " <> secretKey) + sendRequest connection q (jsonBody completionRequest) + onStart + receiveResponse connection handler - let handler = \p i -> do - let status = getStatusCode p - if status == 200 - then do - x <- Streams.foldM (parseResponseChunk callback) ("", "") i - return (Right (snd x)) - else do - x <- Streams.fold mappend mempty i - return (Left $ "an error happend: " <> Text.pack (show x)) - - onStart - receiveResponse connection handler where - parseResponseChunk :: (Text -> IO ()) -> (ByteString, Text) -> ByteString -> IO (ByteString, Text) - parseResponseChunk callback (curBuffer, chunk) input = do - case ByteString.stripPrefix "data: " (ByteString.strip (curBuffer <> input)) of - Just json -> do - case decodeStrict json of - Just CompletionResult { choices } -> do - let tokens :: Text = mconcat $ map (.text) choices - callback tokens - pure ("", chunk <> tokens) - otherwise -> do - pure (curBuffer <> json, chunk) - Nothing -> pure (curBuffer <> input, chunk) + handler :: Response -> Streams.InputStream ByteString -> IO (Either Text Text) + handler response stream = do + let status = getStatusCode response + if status == 200 + then do + {- + parse stream line by line as event stream format according to API spec: + https://platform.openai.com/docs/api-reference/chat/create#chat/create-stream + https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events#event_stream_format + -} + (_, _, output) <- Streams.lines stream >>= Streams.foldM (parseResponseChunk callback) ("", False, "") + return (Right output) + else do + x :: ByteString <- Streams.fold mappend mempty stream + return (Left $ "an error happend: " <> Text.pack (show x)) + + parseResponseChunk :: (Text -> IO ()) -> (ByteString, Bool, Text) -> ByteString -> IO (ByteString, Bool, Text) + parseResponseChunk callback (curBuffer, emptyLineFound, chunk) input + -- input line is empty, but previous was not, append newline to buffer + | ByteString.null input && not emptyLineFound = pure (curBuffer <> "\n", True, chunk) + -- input line is empty, previous line was already empty: message ended, clear buffer + | ByteString.null input && emptyLineFound = pure ("", True, chunk) + -- lines starting with : are comments, ignore + | ":" `ByteString.isPrefixOf` input = pure (curBuffer, False, chunk) + -- try to parse line together with buffer otherwise + | otherwise = case ByteString.stripPrefix "data: " (ByteString.strip (curBuffer <> input)) of + Just json -> do + case eitherDecodeStrict json of + Right CompletionResult { choices } -> do + let tokens :: Text = mconcat $ map (.text) choices + callback tokens + pure ("", False, chunk <> tokens) + Left err -> pure (curBuffer <> json, False, chunk) + Nothing -> pure (curBuffer <> input, False, chunk) fetchCompletion :: ByteString -> CompletionRequest -> IO Text @@ -192,4 +203,4 @@ fetchCompletionWithoutRetry secretKey completionRequest = do pure (mconcat $ map (.text) completionResult.choices) enableStream :: CompletionRequest -> CompletionRequest -enableStream completionRequest = completionRequest { stream = True } \ No newline at end of file +enableStream completionRequest = completionRequest { stream = True }