Merge branch 'master' into select-required-isNew

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

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

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
+    convertString text = Aeson.fromText text

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"

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

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 }
+enableStream completionRequest = completionRequest { stream = True }