Api.fs

module BadukBot.Api

open BadukBot.Telegram
open System
open System.Net.Http

let private client = 
    let h = new HttpClientHandler()
    h.AllowAutoRedirect <- true
    h.MaxRequestContentBufferSize <- 1024L * 1024L
    h.UseCookies <- false
    let c = new HttpClient(h, true)
    c.Timeout <- TimeSpan.FromSeconds 10.
    c

open Aether
open Chiron
open FSharpx.Async
open FSharpx.Control
open Serilog
open System
open System.IO

let sendRecieve (cmd : string) (content : HttpContent) = 
    async { 
        let cmdLower = (Char.ToLowerInvariant(cmd.[0]).ToString()) + cmd.Substring(1)
        let cmdName = Settings.TelegramEndpoint + cmdLower
        Log.Debug("Sending {cmd} to endpoint {cmdName}", cmd, cmdName)
        try 
            use msg = new HttpRequestMessage(HttpMethod.Post, cmdName)
            msg.Headers.ExpectContinue <- Nullable false
            msg.Content <- content
            let! r = client.SendAsync(msg)
                     |> Async.AwaitTask
                     |> Async.map (fun r -> r.EnsureSuccessStatusCode())
            let! jsonResp = r.Content.ReadAsStringAsync() |> Async.AwaitTask
            Log.Debug(jsonResp)
            let res : Response = jsonResp |> (Json.parse >> Json.deserialize)
            return Choice1Of2 res
        with e -> 
            Log.Error("Network failure: {@E}", e)
            return Choice2Of2 e.Message
    }

let inline sendCommand (cmd : ^T when ^T : (static member ToJson : ^T -> Json<unit>)) = 
    async { 
        Log.Debug("Sending msg {@Cmd}", cmd)
        try 
            let json = cmd |> (Json.serialize >> Json.format)
            use content = new StringContent(json, Settings.enc, "application/json")
            return! sendRecieve (cmd.GetType().Name) content
        with e -> 
            Log.Error("Command {@Cmd} failed: {@E}", cmd, e)
            return Choice2Of2 e.Message
    }

let inline sendContent (cmd : IMultipartMessage) = 
    async { 
        Log.Debug("Sending file {@Cmd}", cmd)
        try 
            use content = new MultipartFormDataContent()
            for p in cmd.Fill() |> List.ofSeq do
                Log.Debug("Added {@P}", p)
                content.Add p
            return! sendRecieve (cmd.GetType().Name) content
        with e -> 
            Log.Error("Content {@Cmd} failed: {@E}", cmd, e)
            return Choice2Of2 e.Message
    }

let Register (url: string) = 
    async { 
        let msg = { Url = url }
        let! netReply = sendCommand msg
        match netReply with
        | Choice1Of2 json -> 
            if not <| json.Ok then failwithf "Error setting web hook: %A" json.Description
        | _ -> return ()
    }

let photoStream() = 
    File.OpenRead "board9x9.png"

let basicReply _ = 
    { ChatId = 0UL
      Photo = photoStream()
      Caption = Some "board9x9.png"
      DisableNotification = None
      ReplyTo = None }

let inline processUpdate (upd : Update) = 
    upd.Message |> Option.map (fun u -> { basicReply() with ChatId = u.Chat.Id })

open FSharpx.Async

let ProcessRequest() = 
    async { 
        let msg = 
            { GetUpdates.Offset = Some 0
              Limit = None
              Timeout = None }
        let! responseChoice = sendCommand msg
        match responseChoice with
        | Choice1Of2 response -> 
            if not response.Ok then 
                Log.Error("Request {@Msg} failed: {Desc}", msg, response.Description.Value)
                return Choice2Of2 response.Description.Value
            else 
                match response.Result with
                | Some(Updates ups) when ups.Length > 0 -> 
                    match processUpdate ups.[0] with
                    | None -> return Choice2Of2 "No messages, reply skipped"
                    | Some reply ->
                        let! r = sendContent reply
                        (reply :> IDisposable).Dispose()
                        return r
                | Some Nothing -> return Choice2Of2 "nothing"
                | _ -> return Choice2Of2 "Unexpected"
        | Choice2Of2 err -> return Choice2Of2 err
    }

Telegram.fs

module BadukBot.Telegram

open Chiron
open Chiron.Operators
open System
open System.Collections.Generic
open System.IO
open System.Net.Http

let private epoch = new DateTime(1970, 1, 1)

let dateFromJson (timeStamp : Json) = 
    match timeStamp with
    | Number x -> epoch.AddSeconds(float x) |> Value
    | _ -> 
        Json.formatWith JsonFormattingOptions.SingleLine timeStamp
        |> sprintf "Failed to parse unix time stamp %s"
        |> Error

let dateOptionFromJson (timeStamp : Json) = 
    match timeStamp with
    | Number x -> Some(epoch.AddSeconds(float x)) |> Value
    | Null _ -> Value None
    | _ -> 
        Json.formatWith JsonFormattingOptions.SingleLine timeStamp
        |> sprintf "Failed to parse unix time stamp %s"
        |> Error

type User = 
    { Id : uint64
      FirstName : string
      LastName : string option
      UserName : string option }
    static member FromJson(_ : User) = 
        (fun i f l u -> 
        { Id = i
          FirstName = f
          LastName = l
          UserName = u }) <!> Json.read "id" <*> Json.read "first_name" <*> Json.tryRead "last_name" 
        <*> Json.tryRead "username"

type Chat = 
    { Id : uint64
      Type : string //“private”, “group”, “supergroup” or “channel”
      Title : string option
      UserName : string option
      FirstName : string option
      LastName : string option }
    static member FromJson(_ : Chat) = 
        (fun i tp tt u f l -> 
        { Id = i
          Type = tp
          Title = tt
          UserName = u
          FirstName = f
          LastName = l }) <!> Json.read "id" <*> Json.read "type" <*> Json.tryRead "title" 
        <*> Json.tryRead "username" <*> Json.tryRead "first_name" <*> Json.tryRead "last_name"

type Location = 
    { Lat : float
      Lon : float }
    static member FromJson(_ : Location) = 
        (fun lon lat -> 
        { Lat = lat
          Lon = lon }) <!> Json.read "longitude" <*> Json.read "latitude"

type MessageEntity = 
    { Type : string // Type of the entity. One of mention (@username), hashtag, bot_command, url, email, bold (bold text), italic (italic text), code (monowidth string), pre (monowidth block), text_link (for clickable text URLs
      Offset : uint16
      Length : uint16
      Url : string option }
    static member FromJson(_ : MessageEntity) = 
        json { 
            let! t = Json.read "type"
            let! off = Json.read "offset"
            let! len = Json.read "length"
            let! url = Json.tryRead "url"
            return { Type = t
                     Offset = off
                     Length = len
                     Url = url }
        }

type PhotoSize = 
    { FileId : string
      Width : uint16
      Height : uint16
      FileSize : uint32 option }
    static member FromJson(_ : PhotoSize) = 
        json { 
            let! fid = Json.read "file_id"
            let! w = Json.read "width"
            let! h = Json.read "height"
            let! fs = Json.tryRead "file_size"
            return { FileId = fid
                     Width = w
                     Height = h
                     FileSize = fs }
        }

type Message = 
    { Id : uint64
      From : User option
      Date : DateTime
      Chat : Chat
      FwdFrom : User option
      FwdOriginDate : DateTime option
      ReplyTo : Message option
      Text : string option
      Photo : PhotoSize list option
      Entities : MessageEntity list option
      Location : Location option
      Caption : string option }
    static member FromJson(_ : Message) = 
        (fun id from date chat fwdFrom fwDt replyTo text ph ents loc cap -> 
        { Id = id
          From = from
          Date = date
          Chat = chat
          FwdFrom = fwdFrom
          FwdOriginDate = fwDt
          ReplyTo = replyTo
          Text = text
          Photo = ph
          Entities = ents
          Location = loc
          Caption = cap }) <!> Json.read "message_id" <*> Json.tryRead "from" 
        <*> Json.readWith dateFromJson "date" <*> Json.read "chat" <*> Json.tryRead "forward_from" 
        <*> Json.tryReadWith dateOptionFromJson "forward_date" <*> Json.tryRead "reply_to_message" 
        <*> Json.tryRead "text" <*> Json.tryRead "photo" <*> Json.tryRead "entities" 
        <*> Json.tryRead "location" <*> Json.tryRead "caption"

type InlineQuery = 
    { Id : string
      From : User
      Query : string
      Offset : string }
    static member FromJson(_ : InlineQuery) = 
        (fun id from query offset -> 
        { Id = id
          From = from
          Query = query
          Offset = offset }) <!> Json.read "id" <*> Json.read "from" <*> Json.read "query" 
        <*> Json.read "offset"

type InlineResult = 
    { Id : string
      From : User
      Query : string }
    static member FromJson(_ : InlineResult) = 
        (fun id from q -> 
        { Id = id
          From = from
          Query = q }) <!> Json.read "result_id" <*> Json.read "from" <*> Json.read "query"

type Update = 
    { Id : uint64
      Message : Message option
      InlineQuery : InlineQuery option
      ChosenInlineResult : InlineResult option }
    static member FromJson(_ : Update) = 
        (fun id msg iq cir -> 
        { Id = id
          Message = msg
          InlineQuery = iq
          ChosenInlineResult = cir }) <!> Json.read "update_id" <*> Json.tryRead "message" 
        <*> Json.tryRead "inline_query" <*> Json.tryRead "chosen_inline_result"

type Result = 
    | Message of Message
    | Updates of Update array
    | Nothing
    static member FromJson(_ : Result) = 
        function 
        | Array empty as json when empty.IsEmpty -> Json.init Nothing json
        | Array arr as json -> 
            Json.init (Updates(arr
                               |> List.map Json.deserialize
                               |> Array.ofList)) json
        | Object _ as json -> Json.init (Message(Json.deserialize json)) json
        | json -> Json.error (sprintf "Couldn't deserialize %A to Result" json) json

type Response = 
    { Ok : bool
      Result : Result option
      Description : string option
      ErrorCode : int option }
    static member FromJson(_ : Response) = 
        (fun k d e r -> 
        { Ok = k
          Result = r
          Description = d
          ErrorCode = e }) <!> Json.read "ok" <*> Json.tryRead "description" 
        <*> Json.tryRead "error_code" <*> Json.tryRead "result"

type ParseMode = 
    | HTML
    | Markdown

type SendMessage = 
    { ChatId : uint64
      Text : string
      DisableNotification : bool option
      ReplyTo : uint64 option }
    static member ToJson(t : SendMessage) = 
        Json.write "chat_id" t.ChatId *> Json.write "text" t.Text 
        *> Json.write "disable_notification" t.DisableNotification 
        *> Json.write "reply_to_message_id" t.ReplyTo

type IMultipartMessage = 
    inherit IDisposable
    abstract Fill : unit -> HttpContent seq

type SendPhoto = 
    { ChatId : uint64
      Caption : string option
      Photo : Stream
      DisableNotification : bool option
      ReplyTo : uint64 option }
    interface IMultipartMessage with
        member x.Fill() = 
            seq { 
                let kv = 
                    seq { 
                        yield KeyValuePair("chat_id", x.ChatId.ToString())
                        if x.Caption.IsSome then yield KeyValuePair("caption", x.Caption.Value)
                        if x.DisableNotification.IsSome then 
                            yield KeyValuePair("disable_notification", x.Caption.Value)
                        if x.ReplyTo.IsSome then 
                            yield KeyValuePair("reply_to_message_id", x.ReplyTo.Value.ToString())
                    }
                
                let form = new FormUrlEncodedContent(kv)
                form.Headers.ContentType.MediaType <- "application/x-www-form-urlencoded"
                form.Headers.ContentDisposition <- Headers.ContentDispositionHeaderValue
                                                       ("form-data")
                form.Headers.ContentDisposition.Name <- "params"
                yield upcast form
                x.Photo.Position <- 0L
                let photo = new StreamContent(x.Photo)
                photo.Headers.ContentType <- Headers.MediaTypeHeaderValue("image/png")
                photo.Headers.ContentDisposition <- Headers.ContentDispositionHeaderValue
                                                        ("form-data")
                photo.Headers.ContentDisposition.Name <- "photo"
                photo.Headers.ContentDisposition.FileName <- "test.png"
                yield upcast photo
            }
        
        member x.Dispose() : unit = () //x.Photo.Dispose()

type SetWebhook = 
    { Url : string }
    static member ToJson(t : SetWebhook) = Json.write "url" t.Url

type GetUpdates = 
    { Offset : int option
      Limit : int option
      Timeout : uint16 option }
    static member ToJson(t : GetUpdates) = 
        json { 
            if t.Offset.IsSome then do! Json.write "offset" t.Offset.Value
            if t.Limit.IsSome then do! Json.write "limit" t.Limit.Value
            if t.Timeout.IsSome then do! Json.write "timeout" t.Timeout.Value
        }