Skip to content

Instantly share code, notes, and snippets.

@harryaskham

harryaskham/server.hs

Created March 16, 2023 14:50
Show Gist options
  • Save harryaskham/68a611bef777525991790bca2f2d324d to your computer and use it in GitHub Desktop.
Save harryaskham/68a611bef777525991790bca2f2d324d to your computer and use it in GitHub Desktop.
Download ZIP
GPT-4 Written ChatGPT WebApp in Haskell
Raw
server.hs
{- cabal:
build-depends: base
, scotty
, aeson
, http-client-tls
, http-client
, bytestring
, text
, http-types
-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, Object, ToJSON, Value, decode, encode, object, withObject, (.:), (.=))
import Data.Aeson.Types (parseJSON, parseMaybe, toJSON)
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Lazy.Char8 (pack)
import Data.Maybe (listToMaybe)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as TLE
import Network.HTTP.Client (Request (..), RequestBody (..), defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Header (hAuthorization, hContentType)
import System.Environment (lookupEnv)
import Web.Scotty
data Message = Message
{ role :: Text,
content :: Text
}
deriving (Show)
instance FromJSON Message where
parseJSON = withObject "Message" $ \v ->
Message <$> v .: "role" <*> v .: "content"
instance ToJSON Message where
toJSON (Message role content) =
object ["role" .= role, "content" .= content]
chatGptApiUrl :: String
chatGptApiUrl = "https://api.openai.com/v1/chat/completions"
fetchAssistantReply :: [Message] -> IO (Maybe Text)
fetchAssistantReply messages = do
manager <- newManager tlsManagerSettings
request <- parseRequest chatGptApiUrl
apiKey <- liftIO $ lookupEnv "API_KEY"
case apiKey of
Just key -> do
let requestJson = object ["model" .= ("gpt-3.5-turbo" :: Text), "messages" .= messages]
postRequest =
request
{ method = "POST",
requestBody = RequestBodyLBS . encode $ requestJson,
requestHeaders =
[ (hAuthorization, "Bearer " <> LBS.toStrict (TLE.encodeUtf8 (T.pack key))),
(hContentType, "application/json")
]
}
response <- httpLbs postRequest manager
case decode (responseBody response) >>= extractAssistantReply of
Just reply -> return $ Just reply
Nothing -> return Nothing
Nothing -> return Nothing
extractAssistantReply :: Object -> Maybe Text
extractAssistantReply obj = do
choices <- parseMaybe (.: "choices") obj
firstChoice <- listToMaybe choices
msg <- parseMaybe (.: "message") firstChoice
content <- parseMaybe (.: "content") msg
return content
main :: IO ()
main = scotty 3000 $ do
get "/" $ do
html $
"<html>\
\ <head>\
\ <title>Chat with ChatGPT</title>\
\ <link href='https://fonts.googleapis.com/css2?family=Roboto:wght@400;700&display=swap' rel='stylesheet'>\
\ <link href='https://fonts.googleapis.com/css2?family=Lato:wght@400;700&display=swap' rel='stylesheet'>\
\ <style>\
\ body { font-family: 'Roboto', sans-serif; font-size: 16px; line-height: 1.6; color: #333; margin: 0; padding: 0; }\
\ h1, h2, h3, h4, h5, h6 { font-family: 'Lato', sans-serif; font-weight: 700; color: #333; margin-top: 0; }\
\ a { color: #1abc9c; text-decoration: none; }\
\ a:hover { color: #16a085; }\
\ .container { max-width: 1200px; margin: 0 auto; padding: 0 15px; }\
\ header { background: #f5f5f5; padding: 1rem 0; }\
\ header h1 { margin: 0; }\
\ main { padding: 2rem 0; }\
\ footer { background: #f5f5f5; padding: 1rem 0; text-align: center; }\
\ </style>\
\ </head>\
\ <body>\
\ <header><div class='container'><h1>Chat with ChatGPT</h1></div></header>\
\ <main><div class='container'>\
\ <form method='POST' action='/chat'>\
\ <label for='userMessage'>Your message:</label>\
\ <input type='text' name='userMessage' required>\
\ <input type='submit' value='Send'>\
\ </form>\
\ </div></main>\
\ <footer><div class='container'>&copy; 2023 Chat with ChatGPT. All rights reserved.</div></footer>\
\ </body>\
\ </html>"
post "/chat" $ do
userMsg <- param "userMessage"
let messages = [Message "user" userMsg]
mAssistantReply <- liftIO $ fetchAssistantReply messages
case mAssistantReply of
Just assistantReply -> do
html $
"<html>\
\ <head>\
\ <title>Chat with ChatGPT</title>\
\ <link href='https://fonts.googleapis.com/css2?family=Roboto:wght@400;700&display=swap' rel='stylesheet'>\
\ <link href='https://fonts.googleapis.com/css2?family=Lato:wght@400;700&display=swap' rel='stylesheet'>\
\ <style>\
\ body { font-family: 'Roboto', sans-serif; font-size: 16px; line-height: 1.6; color: #333; margin: 0; padding: 0; }\
\ h1, h2, h3, h4, h5, h6 { font-family: 'Lato', sans-serif; font-weight: 700; color: #333; margin-top: 0; }\
\ a { color: #1abc9c; text-decoration: none; }\
\ a:hover { color: #16a085; }\
\ .container { max-width: 1200px; margin: 0 auto; padding: 0 15px; }\
\ header { background: #f5f5f5; padding: 1rem 0; }\
\ header h1 { margin: 0; }\
\ main { padding: 2rem 0; }\
\ footer { background: #f5f5f5; padding: 1rem 0; text-align: center; }\
\ </style>\
\ </head>\
\ <body>\
\ <header><div class='container'><h1>Chat with ChatGPT</h1></div></header>\
\ <main><div class='container'>\
\ <p><strong>You:</strong> "
<> userMsg
<> "</p>\
\ <p><strong>ChatGPT:</strong> "
<> assistantReply
<> "</p>\
\ <a href='/'>Back to chat</a>\
\ </div></main>\
\ <footer><div class='container'>&copy; 2023 Chat with ChatGPT. All rights reserved.</div></footer>\
\ </body>\
\ </html>"
Nothing -> do
html $
"<html>\
\ <head>\
\ <title>Chat with ChatGPT</title>\
\ <link href='https://fonts.googleapis.com/css2?family=Roboto:wght@400;700&display=swap' rel='stylesheet'>\
\ <link href='https://fonts.googleapis.com/css2?family=Lato:wght@400;700&display=swap' rel='stylesheet'>\
\ <style>\
\ body { font-family: 'Roboto', sans-serif; font-size: 16px; line-height: 1.6; color: #333; margin: 0; padding: 0; }\
\ h1, h2, h3, h4, h5, h6 { font-family: 'Lato', sans-serif; font-weight: 700; color: #333; margin-top: 0; }\
\ a { color: #1abc9c; text-decoration: none; }\
\ a:hover { color: #16a085; }\
\ .container { max-width: 1200px; margin: 0 auto; padding: 0 15px; }\
\ header { background: #f5f5f5; padding: 1rem 0; }\
\ header h1 { margin: 0; }\
\ main { padding: 2rem 0; }\
\ footer { background: #f5f5f5; padding: 1rem 0; text-align: center; }\
\ </style>\
\ </head>\
\ <body>\
\ <main><div class='container'>\
\ <h1>Chat with ChatGPT</h1>\
\ <p>Error: Could not get a response from ChatGPT.</p>\
\ <a href='/'>Back to chat</a>\
\ </div></main>\
\ <footer><div class='container'>&copy; 2023 Chat with ChatGPT. All rights reserved.</div></footer>\
\ </body>\
\</html>"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment